Internet Info 1994 March

home *** CD-ROM | disk | FTP | other *** search

/ Internet Info 1994 March / Internet Info CD-ROM (Walnut Creek) (March 1994).iso / networking / terms / kermit / b / tsnalp.pli < prev next >

Wrap

Text File | 1988-08-16 | 243.6 KB | 3,081 lines

/* ALP -- ASSEMBLY LANGUAGE PREPROCESSOR -- VERSION 6.19 -- 04/02/88 */00001000 (SUBRG): /* CHECK SUBSCRIPTS */ /*RAF-3*/ 00001500 ALP: 00002000 PROCEDURE OPTIONS(MAIN) REORDER; 00003000 /*RAF-24*/ 00003100 DECLARE PLIXOPT CHAR(32) VARYING STATIC EXTERNAL /*RAF-24*/ 00003200 INIT('ISASIZE(70K)'); /*RAF-40*/ /*RAF-24*/ 00003300 /*RAF-24*/ 00003400 DEFAULT RANGE(*) ALIGNED; /*RAF-46*/ 00003500 /*RAF-46*/ 00003600 /* 00004000 INTERNAL PROCEDURES: 00005000 ALP (MAIN CONTROL PROGRAM) 00006000 STMNT 00007000 GROUP 00008000 CEND,CIF,CCASE,CWHILE,CDO,CFOR,CFOREVER,CGOTO,CEXIT,CNEXT, 00009000 CUSE,CASMIF,CMACRO,CBAL,CPCASE,ALCSTMT 00010000 PRED,GB 00011000 WLABEL,WFLUSH 00012000 GENSYM 00013000 00014000 INPUT (INPUT SCANNING PROCEDURES) 00015000 RWORD,ROPANDS 00016000 RCHECK,RCHAR 00017000 SKIP,INC,ALPHANUM 00018000 00019000 ERROR,OUTPUT 00020000 00021000 INPUT/OUTPUT CONVENTIONS: 00022000 00023000 INPUT FILE: 00024000 SYSIN -- CARDS IN ALP LANGUAGE 00025000 00026000 OUTPUT FILES: 00027000 SYSOUT -- CARD IMAGES FOR BAL ASSEMBLER 00028000 SYSPRINT -- INPUT IMAGES AND MESSAGES 00029000 SYSTERM -- MESSAGE DATA SET 00030000 */ 00031000 1 00032000 %DECLARE (#TRUE,#FALSE,#DUMMY) CHARACTER; 00033000 %#TRUE='''1''B'; 00034000 %#FALSE='''0''B'; 00035000 %#DUMMY='''0''B'; 00036000 %DECLARE (@OUTER_PREDICATE,@INNER_PREDICATE) CHARACTER; 00037000 %@OUTER_PREDICATE='''1''B'; 00038000 %@INNER_PREDICATE='''0''B'; 00039000 %DECLARE (@USE_NEGATED,@USE_TRUTH) CHARACTER; 00040000 %@USE_NEGATED='''1''B'; 00041000 %@USE_TRUTH='''0''B'; 00042000 %DECLARE (@B,@BR) CHARACTER; 00043000 %@B='''0''B'; 00044000 %@BR='''1''B'; 00045000 00046000 %DECLARE CALLINC CHARACTER; 00047000 %CALLINC = ' DO; ' 00048000 || ' IF COL>72 THEN CALL INC; ' 00049000 || ' COL = COL+1; ' 00050000 || ' IF COL=73 THEN ' 00051000 || ' CHAR= '' '';' 00052000 || ' ELSE ' 00053000 || ' CHAR=SUBSTR(CARDIN,COL,1); ' 00054000 || ' END '; 00055000 /*RAF-41*/ 00055100 % ALPHANUM: PROCEDURE(CHAR) RETURNS(CHARACTER); /*RAF-41*/ 00055200 DECLARE CHAR CHARACTER; /*RAF-41*/ 00055300 RETURN('(('||CHAR||')>=''A'' | ('||CHAR||')=''$'' | '|| /*RAF-41*/ 00055400 '('||CHAR||')=''#'' | ('||CHAR||')=''@'')'); /*RAF-41*/ 00055500 % END ALPHANUM; /*RAF-41*/ 00055600 % ACTIVATE ALPHANUM; /*RAF-41*/ 00055700 00056000 %GEN: PROCEDURE(OPERATION,OPERANDS) RETURNS(CHARACTER); 00057000 DECLARE (OPERATION,OPERANDS) CHARACTER; 00058000 DECLARE STRING CHARACTER; 00059000 STRING='DO; '; 00060000 IF OPERATION ^= '''''' THEN 00061000 STRING = STRING||'C_OPERATION = '||OPERATION||';'; 00062000 IF OPERANDS ^= '''''' THEN 00063000 STRING = STRING||' GEN_OPERANDS('||OPERANDS||');'; /*RAF-11*/ 00064000 ELSE STRING = STRING||' CALL WFLUSH;'; /*RAF-11*/ 00064500 RETURN(STRING||' END '); /*RAF-11*/ 00065000 %END GEN; 00066000 %ACTIVATE GEN; 00067000 00068000 %GEN_OPERANDS: PROCEDURE(OPERANDS) RETURNS(CHARACTER); /*RAF-11*/ 00069000 DECLARE OPERANDS CHARACTER; /*RAF-11*/ 00070000 RETURN(' DO; ' /*RAF-11*/ 00071000 || ' OP_SAVE = '||OPERANDS||';' /*RAF-11*/ 00072000 || ' C_OPERANDS = OP_SAVE;' /*RAF-11*/ 00073000 || ' DO OP_COUNT=53 TO LENGTH(OP_SAVE) BY 56;' /*RAF-11*/ 00074000 || ' C_CONTINUE = ''*'';' /*RAF-11*/ 00075000 || ' CALL WFLUSH;' /*RAF-11*/ 00076000 || ' C_DATA = '''';' /*RAF-11*/ 00077000 || ' C_CONT_OPERANDS = SUBSTR(OP_SAVE,OP_COUNT);' /*RAF-11*/ 00078000 || ' END;' /*RAF-11*/ 00079000 || ' CALL WFLUSH;' /*RAF-11*/ 00080000 || ' END'); /*RAF-11*/ 00081000 /*RAF-11*/ 00082000 /*RAF-11*/ 00083000 /*RAF-11*/ 00084000 /*RAF-11*/ 00085000 %END GEN_OPERANDS; 00086000 %ACTIVATE GEN_OPERANDS; 00087000 1 00088000 /* "ALP" "INPUT" INTERFACE */ 00089000 DECLARE 00090000 INAL FIXED BIN INIT(2), 00091000 ENDFLG BIT(1) INIT(#FALSE), ENDMARK CHAR(8) STATIC, 00092000 SYSIN FILE RECORD INPUT, 00093000 CHAR CHAR(1) INIT(' ') , /* ALWAYS CONTAINS THE CHARACTER 00094000 POINTED TO BY THE INPUT POINTER */ 00095000 WORD CHAR(8) VARYING, WORDAL BIT(1), /* SET BY RWORD*/ 00096000 OPANDS CHAR(2000) VARYING, /* SET BY ROPANDS */ /*RAF-44*/ 00097000 CARDIN CHAR(80) UNALIGNED, /* INPUT BUFFER*/ /*RAF-46*/ 00098000 CIN_DATA CHAR(72) POS(1) DEF CARDIN UNALIGNED, /*RAF-46*/ 00099000 CIN_ID CHAR(8) POS(73) DEF CARDIN UNALIGNED, /*RAF-46*/ 00100000 CIN_2COLS CHAR(2) POS(1) DEF CARDIN UNAL, /*RAF-46*/ /*RAF-9*/ 00100500 COL FIXED BIN INIT(80); /* INPUT COLUMN WITHIN CARDIN */ 00101000 00102000 /* "ALP" "OUTPUT" INTERFACE" */ 00103000 DECLARE 00104000 SYSPRINT FILE PRINT ENV(FB,RECSIZE(133)), /*RAF-19*/ 00105000 SYSTERM FILE OUTPUT ENV(FB,RECSIZE(121),BLKSIZE(121)), 00106000 SYSOUT FILE RECORD OUTPUT ENV(FB,RECSIZE(80),TOTAL),/*RAF-19*/ 00107000 CARDOUT CHAR(80) INIT(' ') UNAL, /*OUTPUT BUFFER*/ /*RAF-46*/ 00108000 C_LABEL CHAR(8) POS(1) DEF CARDOUT UNALIGNED, /*RAF-46*/ 00109000 COL_1 CHAR(1) POS(1) DEF CARDOUT UNALIGNED, /*RAF-46*/ 00110000 C_DATA CHAR(72) POS(1) DEF CARDOUT UNALIGNED, /*RAF-46*/ 00111000 COUT_ID CHAR(8) POS(73) DEF CARDOUT UNALIGNED, /*RAF-46*/ 00112000 C_OPERATION CHAR(8) POS(10) DEF CARDOUT UNALIGNED, /*RAF-46*/ 00113000 C_OPERANDS CHAR(52) POS(20) DEF CARDOUT UNALIGNED, /*RAF-46*/ 00114000 C_CONTINUE CHAR(1) POS(72) DEF CARDOUT UNALIGNED, /*RAF-46*/ 00115000 C_CONT_OPERANDS CHAR(56) POS(16) DEF CARDOUT UNAL, /*RAF-46*/ 00116000 OP_COUNT FIXED BIN, /*RAF-11*/ 00116100 OP_SAVE CHAR(2000) VARYING, /*RAF-44*/ /*RAF-11*/ 00116200 GENNUM FIXED DEC(5) INIT(10000) STATIC; 00117000 00118000 DECLARE 00119000 ERRCNT FIXED BIN INIT(0), 00120000 (BRANCH_LAST,IN_MACRO,SUBTITL,LABEL_WRITTEN) BIT(1) INIT(#FALSE), 00121000 NESTLEV FIXED BIN INIT(0),NESTID(75) CHAR(8), 00122000 DOLEV FIXED BIN INIT(0), 00123000 (EXID(75),DOID(75),DOLABEL(75)) CHAR(8) VARYING, 00124000 ASMDOLEV FIXED BIN INIT(0), /*RAF-9*/ 00124100 (ASMEXID(75),ASMDOID(75),ASMDOLABEL(75)) /*RAF-9*/ 00124200 CHAR(8) VARYING, /*RAF-9*/ 00124300 PREDLABLEV FIXED BIN INIT(0), /*RAF-6*/ 00125000 PREDLABSTK(100,2) CHAR(14) VARYING, /*RAF-49*/ /*RAF-6*/ 00125500 PREDBTYPE(50) CHAR(1), /*RAF-6*/ 00126000 SYMLEV FIXED BIN INIT(0),SYMSTK(3000) CHAR(8) VARYING,/*RAF-38*/ 00127000 LABLEV FIXED BIN INIT(0),LABSTK(50) CHAR(8) VARYING,/*RAF-42*/ 00128000 EQVLEV FIXED BIN INIT(0), /*RAF-37*/ 00129000 EQVSTK(100,2) CHAR(10) VARYING; /*RAF-37*/ 00129500 00130000 DECLARE 00131000 DTE CHAR(6),TIM CHAR(9),TIME_STAMP CHAR(20), 00132000 PAGECNT FIXED BIN INIT(0), 00133000 DECKNAME CHAR(8) INIT(' '), 00134000 TITLE CHAR(72) INIT( 00135000 'A L P : A S S E M B L E R P R E P R O C E S S O R .' 00136000 ), 00137000 SUBTITLE CHAR(72) INIT(' '); 00138000 0 00139000 /* "ALP" RETURN CODE */ 00140000 DECLARE 00141000 RETCODE FIXED BINARY(31) INIT(0); 00142000 1 00143000 DECLARE 00144000 PREDICATES (18,2) CHAR(8) STATIC INIT( 00145000 'OPENP' , 'NZ' , /* TM */ 00146000 'TM' , 'NZ', /* ANY SELECTED BIT ON */ 00147000 'TS' , 'NZ', 00148000 'TF' , 'NZ', 00149000 'TRT' , 'NZ', 00150000 'RM' , 'M' , /* REGISTER TESTS */ 00151000 'RZ' , 'Z' , 00152000 'RP' , 'P' , 00153000 'RMZ' , 'NP', 00154000 'RMP' , 'NZ', 00155000 'RZP' , 'NM', 00156000 'RNM' , 'NM', 00157000 'RNZ' , 'NZ', 00158000 'RNP' , 'NP', 00159000 'RNMZ' , 'P' , 00160000 'RNMP' , 'Z' , 00161000 'RNZP' , 'M' , 00162000 '***' , 'E'), /* DEFAULT: TRUTH IS EQUAL */ 00163000 00164000 1 CCTAB STATIC, 00165000 2 IVAL(19) INIT((3)0, (5)8, (4)4, (4)2, (3)1), 00166000 2 LET CHAR(19) INIT(' N^ 0=EZ 1LM 2PH 3O'), 00167000 00168000 OPTAB (16) CHAR(10) STATIC INIT( 00169000 'BC 0,', 00170000 'BO', 00171000 'BH', 00172000 'BC 3,', 00173000 'BL', 00174000 'BC 5,', 00175000 'BC 6,', 00176000 'BNE', 00177000 'BE', 00178000 'BC 9,', 00179000 'BC 10,', 00180000 'BNL', 00181000 'BC 12,', 00182000 'BNH', 00183000 'BNO', 00184000 'BC 15,' ); 00185000 1 00186000 ON ENDFILE(SYSIN) GO TO MAIN_END ; 00187000 00188000 OPEN FILE(SYSPRINT) LINESIZE(132); /*RAF-19*/ 00188500 ON ENDPAGE(SYSPRINT) 00189000 BEGIN; 00190000 PAGECNT = PAGECNT+1; 00191000 PUT PAGE FILE(SYSPRINT) 00192000 EDIT(DECKNAME,TITLE,TIME_STAMP,'PAGE ',PAGECNT,SUBTITLE) 00193000 (A(8),A(72),X(9),A(20),X(3),A(5),P'ZZ9',SKIP,X(8),A(72)); 00194000 PUT SKIP(2) FILE(SYSPRINT); 00195000 SUBTITL = #FALSE; 00196000 END; 00197000 00198000 OPEN FILE(SYSTERM); PUT SKIP FILE(SYSTERM); CLOSE FILE(SYSTERM); 00199000 OPEN FILE(SYSOUT); /*RAF-19*/ 00200000 00201000 DTE = DATE() ; TIM = TIME() ; 00202000 TIME_STAMP = SUBSTR(DTE,3,2)||'/'|| 00203000 SUBSTR(DTE,5,2)||'/'|| 00204000 SUBSTR(DTE,1,2)||' '|| 00205000 SUBSTR(TIM,1,2)||':'|| 00206000 SUBSTR(TIM,3,2)||':'|| 00207000 SUBSTR(TIM,5,2) ; 00208000 00209000 PUT SKIP FILE(SYSTERM) EDIT('*ALP*',TIME_STAMP) (A,X(2),A); 00210000 SIGNAL ENDPAGE(SYSPRINT); 00211000 1 00212000 MAIN_LOOP: 00213000 DO WHILE(#TRUE); /* MAIN PROGRAM LOOP*/ 00214000 CALL STMNT ; 00215000 IF ^RCHAR(';') THEN 00216000 CALL ERROR ('MA10: MISSING SEMICOLON INSERTED.') ; 00217000 CALL EQVFLUSH(#FALSE,1); 00218000 END MAIN_LOOP ; 00219000 00220000 MAIN_END : 00221000 CALL EQVFLUSH(#TRUE,1); 00222000 IF ^ENDFLG THEN 00223000 CALL ERROR('MAIN: MISSING "END" AT END OF PROGRAM.'); 00224000 WORD = 'END'; 00225000 COL = 1; 00226000 SUBSTR(CARDIN,1,1),CHAR = ';'; 00227000 CALL ALCSTMT; 00228000 IF NESTLEV^=0 THEN 00229000 DO; 00230000 CALL OUTPUT(' '); 00231000 CALL OUTPUT('MISSING "END"/">" FOR "BEGIN"/"<" AT:'); 00232000 DO NESTLEV = NESTLEV TO 1 BY -1; 00233000 CALL OUTPUT(NESTID(NESTLEV)); 00234000 END; 00235000 RETCODE=8; 00236000 END; 00237000 CALL OUTPUT(' '); 00238000 IF ERRCNT = 0 THEN 00239000 CALL OUTPUT('NO ALP STATEMENTS FLAGGED.'); 00240000 ELSE 00241000 IF ERRCNT = 1 THEN 00242000 CALL OUTPUT('1 ALP STATEMENT FLAGGED.'); 00243000 ELSE 00244000 CALL OUTPUT(ERRCNT||' ALP STATEMENTS FLAGGED.'); 00245000 CALL OUTPUT(' '); 00246000 CLOSE FILE(SYSTERM),FILE(SYSPRINT),FILE(SYSOUT),FILE(SYSIN); 00247000 CALL PLIRETC(RETCODE); 00248000 RETURN ; 00249000 1 00250000 STMNT: /* PROCESS ONE STATEMENT (SIMPLE OR COMPOUND) */ 00251000 PROCEDURE RECURSIVE ; 00252000 DCL 00253000 SAVID CHAR(8); 00254000 00255000 ST: 00256000 CALL RLABEL ; 00257000 IF ENDFLG THEN 00258000 DO; 00259000 CALL ERROR('ST10: EXTRANEOUS OR LABELED "END" AT ' 00260000 ||ENDMARK||' IGNORED.'); 00261000 ENDFLG = #FALSE; 00262000 END; 00263000 IF WORD = ';' THEN 00264000 RETURN; 00265000 SAVID = CIN_ID; 00266000 IF ^WORDAL THEN 00267000 IF WORD = '<' THEN 00268000 DO; 00269000 CALL GROUP(#FALSE,SAVID); 00270000 RETURN; 00271000 END; 00272000 ELSE 00273000 DO; 00274000 CALL ERROR('ST15: "'||WORD||'" OUT OF CONTEXT, IGNORED.');00275000 GO TO ST; 00276000 END; 00277000 00278000 /* WORD IS A SYMBOL */ 00279000 IF WORD = 'BEGIN' THEN 00280000 DO; 00281000 CALL GROUP(#TRUE,SAVID); 00282000 RETURN; 00283000 END; 00284000 ELSE 00285000 IF RCHAR(':') THEN 00286000 DO; 00287000 CALL WLABEL(WORD); 00288000 GO TO ST; 00289000 END; 00290000 1 00291000 /* IDENTIFY ALP INSTRUCTIONS */ 00292000 IF WORD = 'IF' THEN 00293000 CALL CIF ; 00294000 ELSE 00295000 IF WORD = 'CASE' THEN 00296000 CALL CCASE ; 00297000 ELSE 00298000 IF WORD = 'WHILE' THEN 00299000 CALL CWHILE(#FALSE) ; 00300000 ELSE 00301000 IF WORD = 'UNTIL' THEN 00302000 CALL CWHILE(#TRUE); 00303000 ELSE 00304000 IF WORD = 'DO' THEN 00305000 CALL CDO; 00306000 ELSE 00307000 IF WORD = 'FOR' THEN 00308000 CALL CFOR; 00309000 ELSE 00310000 IF WORD = 'FOREVER' THEN 00311000 CALL CFOREVER; 00312000 ELSE 00313000 IF WORD = 'GOTO' THEN 00314000 CALL CGOTO(#FALSE); 00315000 ELSE 00316000 IF WORD = 'RGOTO' THEN 00317000 CALL CGOTO(#TRUE); 00318000 ELSE 00319000 IF WORD = 'EXIT' THEN 00320000 CALL CEXIT; 00321000 ELSE 00322000 IF WORD = 'USE' THEN 00323000 CALL CUSE; 00324000 ELSE 00325000 IF WORD = 'BAL' THEN 00326000 DO; 00327000 IF RCHAR(';') THEN 00328000 CALL CBAL; 00329000 ELSE 00330000 CALL ALCSTMT; 00331000 END; 00332000 ELSE IF WORD = 'COMMENT' THEN /*RAF-10*/ 00332100 DO; /*RAF-10*/ 00332200 IF RCHAR(';') THEN /*RAF-10*/ 00332300 CALL CCOMMENT; /*RAF-10*/ 00332400 ELSE /*RAF-10*/ 00332500 CALL ALCSTMT; /*RAF-10*/ 00332600 END; /*RAF-10*/ 00332700 ELSE IF WORD='DATA' THEN /*RAF-36*/ 00332800 CALL CDATA; /*RAF-36*/ 00332900 ELSE 00333000 IF WORD = 'END' THEN 00334000 CALL CEND(SAVID); 00335000 ELSE 00336000 IF WORD = 'NEXT' THEN 00337000 CALL CNEXT; 00338000 ELSE 00339000 IF WORD='ASM' THEN /*RAF-9*/ 00339100 CALL CASM; /*RAF-9*/ 00339200 ELSE /*RAF-9*/ 00339300 IF WORD = 'ASMIF' THEN 00340000 CALL CASMIF; 00341000 ELSE 00342000 IF WORD = 'MACRO' THEN 00343000 CALL CMACRO; 00344000 ELSE 00345000 IF WORD = 'SELECT' THEN 00346000 CALL CSELECT; 00347000 1 00348000 ELSE 00349000 IF WORD='THEN' 00350000 | WORD='ELSE' 00351000 | WORD='MEND' /*RAF-8*/ 00352000 | WORD='ENDMACRO' /*RAF-8*/ 00352500 | WORD='ENDSEL' 00353000 | WORD='ENDCASE' THEN 00354000 DO; 00355000 CALL ERROR('ST25: INVALID "'||WORD||'" IGNORED.');00356000 GOTO ST; 00357000 END; 00358000 ELSE 00359000 CALL ALCSTMT; 00360000 RETURN ; 00361000 END STMNT ; 00362000 - 00363000 /* PROCESS STATEMENT "GROUP" */ 00364000 GROUP: 00365000 PROCEDURE(BEGTYPE,CARDID) RECURSIVE ; 00366000 DECLARE 00367000 BEGTYPE BIT(1), 00368000 CARDID CHAR(8); 00369000 00370000 NESTLEV=NESTLEV+1; 00371000 NESTID(NESTLEV)=CARDID; 00372000 GRLOOP: 00373000 DO WHILE(#TRUE) ; 00374000 IF ^BEGTYPE THEN DO; /*RAF-7*/ 00375000 IF RCHAR('>') THEN GO TO GROUT; /*RAF-7*/ 00375500 END; /*RAF-7*/ 00376000 ELSE IF RCHECK('END') THEN GO TO GROUT; /*RAF-7*/ 00376500 CALL STMNT ; 00377000 IF ENDFLG THEN /*RAF-7*/ 00377100 DO; /*RAF-7*/ 00377200 CALL ERROR('GR11: EXTRANEOUS OR LABELED "END"' /*RAF-7*/ 00377300 ||' AT '||ENDMARK||' IGNORED.'); /*RAF-7*/ 00377400 ENDFLG = #FALSE; /*RAF-7*/ 00377500 END; /*RAF-7*/ 00377600 IF ^BEGTYPE THEN DO; /*RAF-7*/ 00378000 IF RCHAR('>') THEN GO TO GROUT; /*RAF-7*/ 00378500 END; /*RAF-7*/ 00379000 ELSE IF RCHECK('END') THEN GO TO GROUT; /*RAF-7*/ 00379500 IF ^RCHAR (';') THEN 00380000 CALL ERROR('GR10: MISSING SEMICOLON INSERTED.'); 00381000 END GRLOOP; 00382000 GROUT: 00383000 NESTLEV=NESTLEV-1; 00384000 IF NESTLEV=0 THEN PREDLABLEV=0; /*RAF-6*/ 00384500 RETURN; 00385000 END GROUP ; 00386000 1 00387000 /* END */ 00388000 00389000 CEND: 00390000 PROCEDURE(ENDID); 00391000 DCL 00392000 ENDID CHAR(8); 00393000 00394000 ENDFLG = #TRUE; 00395000 ENDMARK = ENDID; 00396000 RETURN; 00397000 END CEND; 00398000 1 00399000 /* IF <PREDICATE> THEN <STATEMENT> | 00400000 IF <PREDICATE> THEN <STATEMENT> ELSE <STATEMENT> */ 00401000 00402000 CIF: 00403000 PROCEDURE RECURSIVE ; 00404000 DECLARE 00405000 (THENPART,ELSEPART,SKIPLABEL) CHAR(8) VARYING; 00406000 00407000 THENPART = ''; 00408000 ELSEPART = GENSYM; 00409000 CALL PREDICATE(THENPART,ELSEPART,@OUTER_PREDICATE, 00410000 #DUMMY,@USE_TRUTH,#DUMMY,@B); 00411000 IF ^RCHECK('THEN') THEN 00412000 CALL ERROR('CIF: "THEN" INSERTED AFTER "'||WORD||'".'); 00413000 CALL STMNT; /* THEN CLAUSE */ 00414000 IF RCHECK('ELSE') THEN 00415000 DO ; /* ELSE CLAUSE */ 00416000 SKIPLABEL = GENSYM; 00417000 GEN('B',SKIPLABEL); 00418000 CALL WLABEL(ELSEPART) ; 00419000 CALL STMNT; /* ELSE CLAUSE */ 00420000 CALL WLABEL(SKIPLABEL) ; 00421000 END; 00422000 ELSE /* NO ELSE CLAUSE */ 00423000 CALL WLABEL(ELSEPART); 00424000 RETURN; 00425000 END CIF ; 00426000 1 00427000 /* CASE <REGISTER> MAX <MAXVAL>; 00428000 <CASE LIST> 00429000 ENDCASE */ 00430000 00431000 CCASE: 00432000 PROCEDURE RECURSIVE; 00433000 DECLARE 00434000 (REGID,CLABELB,CLABELI,CLABELE,TLABEL) CHAR(8) VARYING, 00435000 ELSEPART CHAR(8) VARYING INIT(''), /*RAF-32*/ 00435100 MINCASE CHAR(80) VARYING INIT('(0)'), /*RAF-32*/ 00435200 MAXCASE CHAR(80) VARYING INIT(''), /*RAF-32*/ 00435300 (CLOW,CHIGH) CHAR(80) VARYING, /*RAF-32*/ 00436000 (EMSG1 CHAR(72) INIT( /*RAF-32*/ 00437000 '* ERROR IF CASE RANGE NOT A MULTIPLE OF FOUR:'), /*RAF-32*/ 00438000 EMSG2 CHAR(72) INIT( /*RAF-32*/ 00439000 '* ERROR IF ORDER OF "THRU" CASES IS INVALID:'), 00440000 EMSG3 CHAR(72) INIT('* ERROR IF CASE OUT OF RANGE:'), /*RAF-32*/ 00441000 EMSG4 CHAR(72) INIT('* ERROR IF CASE NOT A MULTIPLE OF FOUR:'), 00442000 EMSG5 CHAR(72) INIT( /*RAF-32*/ 00442100 '* ERROR IF CASE RANGE NOT GREATER THAN ZERO:') /*RAF-32*/ 00442200 ) STATIC; 00443000 00444000 CALL ROPANDS(#TRUE); /*RAF-32*/ 00445000 IF OPANDS='' THEN /*RAF-32*/ 00446000 DO; 00447000 CALL ERROR('CCASE: NO REGISTER ID FOR CASE STATEMENT.'); 00448000 OPANDS='0'; /*RAF-32*/ /*RAF-8*/ 00449000 END; 00450000 REGID = OPANDS; /*RAF-32*/ 00451000 /* IF ^RCHECK('MAX') THEN */ /*RAF-32*/ /* 00452000 CALL ERROR('CCASE: "MAX" INSERTED AFTER "'||REGID||'".'); 00453000 CALL RWORD; 00454000 IF ^WORDAL THEN 00455000 DO; 00456000 CALL ERROR('CCASE: MISSING MAXIMUM CASE INDICATION.'); 00457000 RETURN; 00458000 END; */ /*RAF-32*/ 00459000 DO WHILE('1'B); /*RAF-32*/ 00459020 IF RCHECK('MAX') THEN DO; /*RAF-32*/ 00459040 CALL ROPANDS(#TRUE); /*RAF-32*/ 00459060 MAXCASE='('||OPANDS||')'; /*RAF-32*/ 00459080 END; /*RAF-32*/ 00459100 ELSE IF RCHECK('MIN') THEN DO; /*RAF-32*/ 00459120 CALL ROPANDS(#TRUE); /*RAF-32*/ 00459140 MINCASE='('||OPANDS||')'; /*RAF-32*/ 00459160 END; /*RAF-32*/ 00459180 ELSE IF RCHECK('CHECK') THEN DO; /*RAF-32*/ 00459200 ELSEPART=GENSYM; /*RAF-32*/ 00459220 END; /*RAF-32*/ 00459240 ELSE DO; /*RAF-32*/ 00459260 IF ^RCHAR(';') THEN /*RAF-32*/ 00459280 CALL ERROR('CCASE: MISSING SEMICOLON INSERTED'); /*RAF-32*/ 00459300 GO TO CASEBODY; /*RAF-32*/ 00459320 END; /*RAF-32*/ 00459340 END; /*RAF-32*/ 00459360 CASEBODY: /*RAF-32*/ 00459380 IF MAXCASE='' THEN DO; /*RAF-32*/ 00459400 CALL ERROR('CCASE: MAX MUST BE SPECIFIED'); /*RAF-32*/ 00459420 MAXCASE=MINCASE; /*RAF-32*/ 00459440 END; /*RAF-32*/ 00459460 CLABELE = ''; /*RAF-32*/ 00460000 DOLEV = DOLEV+1; 00461000 EXID(DOLEV) = ''; /*RAF-8*/ 00462000 DOID(DOLEV) = GENSYM; /*RAF-15*/ 00463000 DOLABEL(DOLEV) = CURLAB; 00464000 /* MAXCASE = WORD; */ /*RAF-32*/ /* 00465000 DO WHILE(^RCHAR(';')); 00466000 CALL RWORD; 00467000 MAXCASE = MAXCASE||WORD; 00468000 END; 00469000 MAXCASE='('||MAXCASE||')'; */ /*RAF-32*/ 00470000 CLABELB = GENSYM; 00471000 CALL WLABEL(DOID(DOLEV)); /*RAF-15*/ 00471500 IF ELSEPART^='' THEN DO; /*RAF-32*/ 00471520 GEN('C',REGID||',=A'||MAXCASE); /*RAF-32*/ 00471540 GEN('BH',ELSEPART); /*RAF-32*/ 00471560 IF MINCASE='(0)' THEN DO; /*RAF-32*/ 00471580 GEN('LTR',REGID||','||REGID); /*RAF-32*/ 00471600 GEN('BM',ELSEPART); /*RAF-32*/ 00471620 END; /*RAF-32*/ 00471640 ELSE DO; /*RAF-32*/ 00471660 GEN('C',REGID||',=A'||MINCASE); /*RAF-32*/ 00471680 GEN('BL',ELSEPART); /*RAF-32*/ 00471700 END; /*RAF-32*/ 00471720 END; /*RAF-32*/ 00471740 GEN('B',CLABELB||'-'||MINCASE||'('||REGID||')'); /*RAF-32*/ 00472000 C_DATA=EMSG1; 00473000 CALL WFLUSH; 00474000 GEN('DS','0CL(1+('||MAXCASE||'-'||MINCASE||')/4*4-'|| /*RAF-32*/ 00475000 MAXCASE||'+'||MINCASE||')'); /*RAF-32*/ 00475100 C_DATA=EMSG5; /*RAF-32*/ 00475200 CALL WFLUSH; /*RAF-32*/ 00475300 GEN('DS','0CL('||MAXCASE||'-'||MINCASE||')'); /*RAF-32*/ 00475400 CALL WLABEL(CLABELB); 00476000 IF ELSEPART='' THEN DO; /*RAF-32*/ 00476500 GEN('DC','(('||MAXCASE||'-'||MINCASE||')/4+1)'|| /*RAF-32*/ 00477000 'H''0,0'''); /*RAF-32*/ 00477100 END; /*RAF-32*/ 00477200 ELSE DO; /*RAF-32*/ 00477300 GEN('DC','(('||MAXCASE||'-'||MINCASE||')/4+1)'|| /*RAF-32*/ 00477400 'S(X''7F0''(4),'||ELSEPART||')'); /*RAF-32*/ 00477500 END; /*RAF-32*/ 00477600 1 00478000 NESTLEV = NESTLEV+1; 00479000 NESTID(NESTLEV) = CIN_ID; 00480000 /* CALL RWORD; */ /*RAF-32*/ 00481000 DO WHILE(^RCHECK('ENDCASE')); /*RAF-32*/ 00482000 IF CLABELE='' /*RAF-32*/ 00482100 THEN CLABELE=GENSYM; /*RAF-32*/ 00482200 ELSE GEN('B',CLABELE); /*RAF-32*/ 00482300 TLABEL = GENSYM; 00483000 CLABELI = GENSYM; 00484000 CALL WLABEL(TLABEL); 00485000 GEN('DS','0H'); 00486000 DO WHILE('1'B); /*RAF-32*/ 00487000 /* CLOW,CHIGH = ''; */ /*RAF-32*/ /* 00488000 DO WHILE(WORD^='THRU' & WORD^=',' & WORD^=':' & WORD^=';'); 00489000 CLOW = CLOW||WORD; 00490000 CALL RWORD; 00491000 END; 00492000 CLOW='('||CLOW||')'; */ /*RAF-32*/ 00493000 CALL ROPANDS(#TRUE); /*RAF-32*/ 00493100 CLOW='('||OPANDS||')'; /*RAF-32*/ 00493200 CHIGH=''; /*RAF-32*/ 00493300 IF RCHECK('THRU') THEN /*RAF-32*/ 00494000 DO ; 00495000 /* CALL RWORD ; */ /*RAF-32*/ /* 00496000 DO 00497000 WHILE(WORD ^= ',' & WORD ^= ':' & WORD ^= ';'); 00498000 CHIGH = CHIGH||WORD; 00499000 CALL RWORD ; 00500000 END; */ /*RAF-32*/ 00501000 CALL ROPANDS(#TRUE); /*RAF-32*/ 00501100 CHIGH='('||OPANDS||')'; /*RAF-32*/ 00501200 END ; 00502000 /* IF CHIGH^='' THEN */ /*RAF-32*/ 00503000 /* CHIGH='('||CHIGH||')'; */ /*RAF-32*/ 00504000 IF RCHAR(';') THEN /*RAF-32*/ 00505000 DO; 00506000 CALL ERROR('CCASE: '|| 00507000 'MISSING CASE LABEL, CASE IGNORED.'); 00508000 GO TO NOCASE; /*RAF-32*/ 00509000 END; 00510000 1 00511000 ELSE 00512000 DO; 00513000 C_DATA=EMSG3; 00514000 CALL WFLUSH; 00515000 GEN('DS','0CL(1+'||MAXCASE||'-'||CLOW||'),' /*RAF-5*/ 00516000 ||'0CL(1+'||CLOW||'-'||MINCASE||')'); /*RAF-32,RAF-5*/ 00516100 C_DATA=EMSG4; 00517000 CALL WFLUSH; 00518000 GEN('DS','0CL(1+('||CLOW||'-'||MINCASE|| /*RAF-32*/ 00519000 ')/4*4-'||CLOW||'+'||MINCASE||')'); /*RAF-32*/ 00519100 IF CHIGH^='' THEN 00520000 DO; 00521000 C_DATA=EMSG2; 00522000 CALL WFLUSH; 00523000 GEN('DS','0CL(1+'||CHIGH||'-'||CLOW||')'); 00524000 C_DATA=EMSG3; 00525000 CALL WFLUSH; 00526000 GEN('DS','0CL(1+'||MAXCASE||'-'||CHIGH||')'); 00527000 C_DATA=EMSG4; 00528000 CALL WFLUSH; 00529000 GEN('DS','0CL(1+('||CHIGH||'-'||MINCASE /*RAF-32*/ 00530000 ||')/4*4-'||CHIGH||'+'||MINCASE||')'); /*RAF-32*/ 00530100 END; 00531000 GEN('ORG',CLABELB||'+'||CLOW||'-'||MINCASE); /*RAF-32*/ 00532000 IF CHIGH = '' THEN 00533000 DO; 00534000 C_OPERATION = 'B'; 00535000 C_OPERANDS = CLABELI; 00536000 END; 00537000 ELSE 00538000 DO; 00539000 C_OPERATION = 'DC'; 00540000 C_OPERANDS = '(('||CHIGH||'-'||CLOW|| 00541000 ')/4+1)S(X''7F0''(4),'||CLABELI||')'; 00542000 END; 00543000 CALL WFLUSH; 00544000 IF ^RCHAR(',') THEN /*RAF-32*/ 00545000 GO TO END_CASE_LIST; /*RAF-32*/ 00546000 END; 00547000 END; 00548000 END_CASE_LIST: /*RAF-32*/ 00548500 IF ^RCHAR(':') THEN /*RAF-32*/ 00548600 CALL ERROR('CCASE: MISSING COLON INSERTED'); /*RAF-32*/ 00548700 GEN('ORG',TLABEL); 00549000 IF ^RCHAR(';') THEN 00550000 DO; 00551000 CALL WLABEL(CLABELI); 00552000 BRANCH_LAST=#TRUE; /*RAF-32*/ 00552500 CALL STMNT; 00553000 IF ^RCHAR(';') THEN 00554000 CALL ERROR('CA10: MISSING SEMICOLON INSERTED.') ; 00555000 /* CALL RWORD; */ /*RAF-32*/ 00556000 /* IF WORD ^= 'ENDCASE' THEN */ /*RAF-32*/ 00557000 /* GEN('B',CLABELE); */ /*RAF-32*/ 00558000 END; 00559000 ELSE 00560000 DO; 00561000 CALL EQVADD((CLABELI),(CLABELE)); 00562000 /* CALL RWORD; */ /*RAF-32*/ 00563000 END; 00564000 NOCASE: /*RAF-32*/ 00564500 END ; 00565000 1 00566000 NESTLEV = NESTLEV-1; /*RAF-34*/ 00566020 00566030 IF ELSEPART='' THEN DO; /*RAF-32*/ 00566050 IF RCHECK('ELSE') THEN DO; /*RAF-32*/ 00566100 CALL ERROR('CCASE: CHECK REQUIRED WITH ELSE'); /*RAF-32*/ 00566150 CALL STMNT; /*RAF-32*/ 00566200 END; /*RAF-32*/ 00566250 END; /*RAF-32*/ 00566300 ELSE DO; /*RAF-32*/ 00566350 GEN('B',CLABELE); /*RAF-32*/ 00566400 CALL WLABEL(ELSEPART); /*RAF-32*/ 00566450 IF RCHECK('ELSE') /*RAF-32*/ 00566500 THEN CALL STMNT; /*RAF-32*/ 00566550 ELSE GEN('DC','H''0'''); /*RAF-32*/ 00566600 END; /*RAF-32*/ 00566650 /*RAF-32*/ 00566700 /* IF DOID(DOLEV)^='' THEN */ /*RAF-15*/ 00567000 /* CALL EQVADD((DOID(DOLEV)),(CLABELB||'-4')); */ /*RAF-15*/ 00568000 CALL WLABEL(CLABELE); 00569000 TLABEL = EXID(DOLEV); /*RAF-8*/ 00569500 DOLEV = DOLEV-1; 00570000 /* NESTLEV = NESTLEV-1; */ /*RAF-34*/ 00571000 IF NESTLEV=0 THEN PREDLABLEV=0; /*RAF-6*/ 00571500 IF RCHECK('THEN') THEN CALL STMNT; /*RAF-8*/ 00571600 CALL CWLABEL(TLABEL); /*RAF-9*/ 00571700 RETURN; 00572000 END CCASE; 00573000 1 00574000 /* WHILE <PRED> DO <STMNT> | UNTIL <PRED> DO <STMNT> */ 00575000 00576000 CWHILE: 00577000 PROCEDURE(UWB) RECURSIVE ; 00578000 DCL 00579000 UWB BIT(1), /* #FALSE => WHILE */ 00580000 (TOP,BODY,FAILURE,DO_LABEL,THENPART) CHAR(8) VARYING; 00581000 00582000 DO_LABEL = CURLAB; 00583000 CALL SWLABEL(TOP); 00584000 FAILURE = GENSYM; 00585000 BODY = ''; 00586000 CALL PREDICATE(BODY,FAILURE,@OUTER_PREDICATE,#DUMMY,UWB,#DUMMY, 00587000 @B); 00588000 IF ^RCHECK('DO') THEN 00589000 CALL ERROR('CWHILE/UNTIL: "DO" INSERTED AFTER "'||WORD||'".'); 00590000 DOLEV = DOLEV+1; 00591000 EXID(DOLEV) = ''; 00592000 DOLABEL(DOLEV) = DO_LABEL; 00593000 DOID(DOLEV) = TOP; 00594000 CALL STMNT; 00595000 GEN('B',TOP); 00596000 CALL WLABEL(FAILURE); 00597000 THENPART = EXID(DOLEV); 00598000 DOLEV = DOLEV-1; 00599000 IF RCHECK('THEN') THEN 00600000 CALL STMNT; 00601000 CALL CWLABEL(THENPART); 00602000 RETURN; 00603000 END CWHILE ; 00604000 1 00605000 /* DO <STMNT> UNTIL/WHILE <PRED> | FOR <REGISTER> | FOREVER */ 00606000 00607000 CDO: 00608000 PROCEDURE RECURSIVE; 00609000 DCL 00610000 FEVER BIT(1) INIT(#FALSE), 00611000 ELEV FIXED BIN, /*RAF-37*/ 00611500 (BODY,PREDFAIL,THENPART) CHAR(8) VARYING, /*RAF-13*/ /*RAF-8*/ 00612000 REG CHAR(64) VARYING; /*RAF-13*/ 00612500 00613000 CALL SWLABEL(BODY); 00614000 PREDFAIL = ''; 00615000 DOLEV = DOLEV+1; 00616000 EXID(DOLEV),DOID(DOLEV) = ''; 00617000 DOLABEL(DOLEV) = CURLAB; 00618000 CALL STMNT; 00619000 IF RCHECK('UNTIL') THEN 00620000 DO; 00621000 CALL CWLABEL(DOID(DOLEV)); 00622000 CALL PREDICATE(PREDFAIL,BODY,@OUTER_PREDICATE,#DUMMY, 00623000 @USE_TRUTH,#DUMMY,@B); 00624000 END; 00625000 ELSE 00626000 IF RCHECK('WHILE') THEN 00627000 DO; 00628000 CALL CWLABEL(DOID(DOLEV)); 00629000 CALL PREDICATE(PREDFAIL,BODY,@OUTER_PREDICATE,#DUMMY, 00630000 @USE_NEGATED,#DUMMY,@B); 00631000 END; 00632000 ELSE 00633000 IF RCHECK('FOR') THEN 00634000 DO; 00635000 CALL CWLABEL(DOID(DOLEV)); 00636000 CALL ROPANDS(#TRUE); /*RAF-13*/ 00637000 IF OPANDS^='' THEN /*RAF-13*/ 00638000 REG=OPANDS; /*RAF-13*/ 00639000 ELSE 00640000 DO; 00641000 REG='0'; 00642000 CALL ERROR('CDO: MISSING "FOR" REGISTER.'); 00643000 END; 00644000 GEN('BCT',REG||','||BODY); 00645000 END; 00646000 ELSE 00647000 IF RCHECK('FOREVER') THEN 00648000 DO; 00649000 FEVER = #TRUE; 00650000 CALL CWLABEL(DOID(DOLEV)); 00651000 GEN('B',BODY); 00652000 END; 00653000 ELSE 00654000 IF DOID(DOLEV) ^= '' THEN DO; /*RAF-37*/ 00655000 ELEV = EQVLEV+1; /*RAF-37*/ 00655500 CALL EQVADD((DOID(DOLEV)),(BODY)); 00656000 CALL EQVFLUSH(#FALSE,ELEV); /*RAF-37*/ 00656100 END; /*RAF-37*/ 00656200 1 00657000 THENPART = EXID(DOLEV); /*RAF-8*/ 00657100 DOLEV = DOLEV-1; /*RAF-8*/ 00657200 IF RCHECK('THEN') THEN 00658000 DO; 00659000 IF FEVER THEN 00660000 CALL ERROR('CDO: INAPPROPRIATE "THEN" IGNORED.'); 00661000 CALL STMNT; 00662000 END; 00663000 CALL CWLABEL(THENPART); /*RAF-8*/ 00664000 /* DOLEV = DOLEV-1; */ /*RAF-8*/ 00665000 RETURN; 00666000 END CDO; 00667000 1 00668000 /* UTILITY PROCEDURE FOR LOOP CONSTRUCTS */ 00669000 CURLAB: PROCEDURE RETURNS(CHAR(8) VARYING); 00670000 DCL CLABEL CHAR(8) VARYING, 00671000 I FIXED BIN; 00672000 00673000 IF C_LABEL = ' ' 00674000 | ((SUBSTR(C_LABEL,1,1)<'A' | SUBSTR(C_LABEL,1,1)>'Z') /*RAF-30*/ 00675000 & SUBSTR(C_LABEL,1,1)^='&') THEN /*RAF-30*/ 00676000 DO; 00677000 DO I=LABLEV TO 1 BY -1 00678000 WHILE(SUBSTR(LABSTK(I),1,1)<'A' 00679000 | SUBSTR(LABSTK(I),1,1)>'Z'); 00680000 END; 00681000 IF I>0 THEN 00682000 CLABEL = LABSTK(I); 00683000 ELSE 00684000 CLABEL = ''; 00685000 END; 00686000 ELSE 00687000 CLABEL = C_LABEL; 00688000 RETURN(CLABEL); 00689000 END CURLAB; 00690000 1 00691000 /* FOR <REGISTER> DO <STATEMENT> */ 00692000 00693000 CFOR: 00694000 PROCEDURE RECURSIVE; 00695000 DCL 00696000 (GEN1,GEN2,GEN3) CHAR(8) VARYING, /*RAF-13*/ 00697000 REG CHAR(64) VARYING; /*RAF-13*/ 00697500 00698000 GEN3 = CURLAB; 00699000 GEN1 = GENSYM; 00700000 GEN2 = GENSYM; 00701000 DOLEV = DOLEV+1; 00702000 EXID(DOLEV),DOID(DOLEV) = ''; 00703000 DOLABEL(DOLEV) = GEN3; 00704000 CALL ROPANDS(#TRUE); /*RAF-13*/ 00705000 IF OPANDS^='' THEN /*RAF-13*/ 00706000 REG = OPANDS; /*RAF-13*/ 00707000 ELSE 00708000 DO; 00709000 REG = '0'; 00710000 CALL ERROR('CFOR: MISSING "FOR" REGISTER.'); 00711000 END; 00712000 GEN('LTR',REG||','||REG); 00713000 GEN('BNP',GEN2); 00714000 CALL WLABEL(GEN1); 00715000 IF ^RCHECK('DO') THEN 00716000 CALL ERROR('CFOR: "DO" INSERTED AFTER "'||REG||'".'); 00717000 CALL STMNT; 00718000 CALL CWLABEL(DOID(DOLEV)); 00719000 GEN('BCT',REG||','||GEN1); 00720000 CALL WLABEL(GEN2); 00721000 GEN3 = EXID(DOLEV); 00722000 DOLEV = DOLEV-1; 00723000 IF RCHECK('THEN') THEN 00724000 CALL STMNT; 00725000 CALL CWLABEL(GEN3); 00726000 RETURN; 00727000 END CFOR; 00728000 1 00729000 /* FOREVER DO <STATEMENT> */ 00730000 00731000 CFOREVER: 00732000 PROCEDURE RECURSIVE ; 00733000 DCL 00734000 (GEN1,GEN2) CHAR(8) VARYING; 00735000 00736000 GEN1 = CURLAB; 00737000 CALL SWLABEL(GEN2) ; 00738000 DOLEV = DOLEV+1; 00739000 EXID(DOLEV),DOID(DOLEV) = ''; 00740000 DOLABEL(DOLEV) = GEN1; 00741000 IF ^RCHECK('DO') THEN 00742000 CALL ERROR('CFOREVER: "DO" ASSUMED AFTER "FOREVER".'); 00743000 CALL STMNT ; 00744000 CALL CWLABEL(DOID(DOLEV)); 00745000 GEN('B',GEN2); 00746000 CALL CWLABEL(EXID(DOLEV)); 00747000 DOLEV = DOLEV-1; 00748000 IF RCHECK('THEN') THEN 00749000 CALL ERROR('CFOREVER: INAPPROPRIATE "THEN" IGNORED.'); 00750000 RETURN; 00751000 END CFOREVER ; 00752000 1 00753000 /* GOTO <LABEL> | GOTO <LABEL> IF <PREDICATE> */ 00754000 /* RGOTO <LABEL> | RGOTO <LABEL> IF <PREDICATE> */ 00755000 00756000 CGOTO: 00757000 PROCEDURE(RTYPE) RECURSIVE; 00758000 DCL 00759000 RTYPE BIT(1); 00760000 DCL 00761000 IFF BIT(1), /* FOR RCHECK */ 00762000 TARGET CHAR(25) VARYING, 00763000 FAIL CHAR(8) VARYING; 00764000 00765000 CALL ROPANDS(#FALSE); /*RAF-39*/ /*RAF-9*/ 00766000 TARGET = OPANDS; 00767000 FAIL = ''; 00768000 IF RCHECK('IF') THEN 00769000 IF CHAR = ';' | CHAR = '>' THEN 00770000 CALL ERROR('CGOTO: EXTRANEOUS "IF" IGNORED.'); 00771000 ELSE 00772000 CALL PREDICATE(FAIL,TARGET,@OUTER_PREDICATE,#DUMMY, 00773000 @USE_NEGATED,#DUMMY,RTYPE); 00774000 ELSE 00775000 DO; 00776000 IF RTYPE THEN 00777000 C_OPERATION = 'BR'; 00778000 ELSE 00779000 C_OPERATION = 'B'; 00780000 GEN('',OPANDS); 00781000 END; 00782000 RETURN; 00783000 END CGOTO; 00784000 1 00785000 /* EXIT FROM <BLOCK LABEL> IF <PREDICATE> */ 00786000 00787000 CEXIT: PROCEDURE RECURSIVE; 00788000 DCL 00789000 I FIXED BIN, 00790000 (EXLABEL,FAIL) CHAR(8) VARYING; 00791000 00792000 IF DOLEV > 0 THEN 00793000 DO; 00794000 EXLABEL,FAIL = ''; I = 0; 00795000 IF RCHECK('FROM') THEN 00796000 IF CHAR = ';' | CHAR = '>' THEN 00797000 CALL ERROR('CEXIT: EXTRANEOUS "FROM" IGNORED.'); 00798000 ELSE 00799000 DO; 00800000 CALL RLABEL; /*RAF-16*/ 00801000 IF WORD^='' THEN /*RAF-16*/ 00802000 DO; 00803000 DO I=1 TO DOLEV WHILE(DOLABEL(I)^=WORD); 00804000 END; 00805000 IF I>DOLEV THEN 00806000 DO; 00807000 I = 0; 00808000 CALL ERROR('CEXIT: NO LABEL TO MATCH "'00809000 ||WORD||'".'); 00810000 END; 00811000 ELSE 00812000 EXLABEL = EXID(I); 00813000 END; 00814000 ELSE 00815000 CALL ERROR('CEXIT: LABEL MISSING AFTER "FROM".');00816000 END; 00817000 IF I=0 THEN I=DOLEV; 00818000 IF EXLABEL = '' THEN 00819000 DO; 00820000 IF EXID(I) = '' THEN 00821000 EXID(I) = GENSYM; 00822000 EXLABEL = EXID(I); 00823000 END; 00824000 IF RCHECK('IF') THEN 00825000 IF CHAR = ';' | CHAR = '>' THEN 00826000 CALL ERROR('CEXIT: EXTRANEOUS "IF" IGNORED.'); 00827000 ELSE 00828000 CALL PREDICATE(FAIL,EXLABEL,@OUTER_PREDICATE,#DUMMY, 00829000 @USE_NEGATED,#DUMMY,@B); 00830000 ELSE 00831000 GEN('B',EXLABEL); 00832000 END; 00833000 ELSE 00834000 CALL ERROR('CEXIT: NO CONTAINING LOOP STRUCTURE FOR "EXIT".'); 00835000 RETURN; 00836000 END CEXIT ; 00837000 1 00838000 /* NEXT OF <BLOCK LABEL> IF <PREDICATE> */ 00839000 00840000 CNEXT: PROCEDURE RECURSIVE; 00841000 DCL 00842000 I FIXED BIN, 00843000 (NXLABEL,FAIL) CHAR(8) VARYING; 00844000 00845000 IF DOLEV > 0 THEN 00846000 DO; 00847000 NXLABEL,FAIL = ''; I = 0; 00848000 IF RCHECK('OF') THEN 00849000 IF CHAR = ';' | CHAR = '>' THEN 00850000 CALL ERROR('CNEXT: EXTRANEOUS "OF" IGNORED.'); 00851000 ELSE 00852000 DO; 00853000 CALL RLABEL; /*RAF-16*/ 00854000 IF WORD^='' THEN /*RAF-16*/ 00855000 DO; 00856000 DO I=1 TO DOLEV WHILE(DOLABEL(I)^=WORD); 00857000 END; 00858000 IF I>DOLEV THEN 00859000 DO; 00860000 I = 0; 00861000 CALL ERROR('CEXIT: NO LABEL TO MATCH "'00862000 ||WORD||'".'); 00863000 END; 00864000 ELSE 00865000 NXLABEL = DOID(I); /*RAF-1*/ 00866000 END; 00867000 ELSE 00868000 CALL ERROR('CNEXT: LABEL MISSING AFTER "OF".'); 00869000 END; 00870000 IF I=0 THEN I=DOLEV; 00871000 IF NXLABEL = '' THEN 00872000 DO; 00873000 IF DOID(I) = '' THEN 00874000 DOID(I) = GENSYM; 00875000 NXLABEL = DOID(I); 00876000 END; 00877000 IF RCHECK('IF') THEN 00878000 IF CHAR = ';' | CHAR = '>' THEN 00879000 CALL ERROR('CNEXT: EXTRANEOUS "IF" IGNORED.'); 00880000 ELSE 00881000 CALL PREDICATE(FAIL,NXLABEL,@OUTER_PREDICATE,#DUMMY, 00882000 @USE_NEGATED,#DUMMY,@B); 00883000 ELSE 00884000 GEN('B',NXLABEL); 00885000 END; 00886000 ELSE 00887000 CALL ERROR('CNEXT: NO CONTAINING LOOP STRUCTURE FOR "NEXT".'); 00888000 RETURN; 00889000 END CNEXT ; 00890000 1 00891000 /* USE <REGISTER> AS <DSECT> IN <STATEMENT> */ 00892000 00893000 CUSE: 00894000 PROCEDURE RECURSIVE; 00895000 DCL 00896000 REGSTR CHAR(51) VAR INIT(''), 00897000 MULTUSE BIT(1) INIT(#TRUE), 00898000 (REG,CONBLK) CHAR(8) VARYING; 00899000 00900000 CALL LABPUSH; 00901000 DO WHILE(MULTUSE); 00902000 CALL RWORD; 00903000 IF WORDAL THEN 00904000 REG = WORD; 00905000 ELSE 00906000 DO; 00907000 REG = '?'; 00908000 CALL ERROR('CUSE: MISSING "USING" REGISTER, "'|| 00909000 WORD||'" IGNORED'); 00910000 END; 00911000 IF ^RCHECK('AS') THEN 00912000 CALL ERROR('CUSE: "AS" ASSUMED BEFORE "'||WORD||'".'); 00913000 CALL RWORD; 00914000 IF WORDAL | WORD = '*' THEN 00915000 CONBLK = WORD; 00916000 ELSE 00917000 DO; 00918000 CONBLK = '???'; 00919000 CALL ERROR('CUSE: MISSING DSECT IDENTIFIER, "'|| 00920000 WORD||'" IGNORED'); 00921000 END; 00922000 GEN('USING',CONBLK||','||REG); 00923000 REGSTR = REGSTR||','||REG; 00924000 MULTUSE = RCHAR(','); 00925000 END; 00926000 IF ^RCHECK('IN') THEN 00927000 CALL ERROR('CUSE: "IN" ASSUMED AFTER "'||CONBLK||'".'); 00928000 CALL STMNT; 00929000 CALL LABPUSH; 00930000 GEN('DROP',SUBSTR(REGSTR,2)); 00931000 RETURN; 00932000 END CUSE; 00933000 1 00933010 CASM: PROCEDURE RECURSIVE; /*RAF-9*/ 00933020 /*RAF-9*/ 00933030 CALL RWORD; /* GET SUBSTATEMENT NAME */ /*RAF-9*/ 00933040 /*RAF-9*/ 00933050 IF WORD='IF' THEN CALL CASMIF; /*RAF-9*/ 00933060 ELSE IF WORD='CASE' THEN CALL CASMCASE; /*RAF-9*/ 00933070 ELSE IF WORD='WHILE' THEN CALL CASMWHILE(#FALSE); /*RAF-9*/ 00933080 ELSE IF WORD='UNTIL' THEN CALL CASMWHILE(#TRUE); /*RAF-9*/ 00933090 ELSE IF WORD='FOREVER' THEN CALL CASMFOREVER; /*RAF-9*/ 00933100 ELSE IF WORD='FOR' THEN CALL CASMFOR; /*RAF-9*/ 00933110 ELSE IF WORD='DO' THEN CALL CASMDO; /*RAF-9*/ 00933120 ELSE IF WORD='SELECT' THEN CALL CASMSELECT; /*RAF-9*/ 00933130 ELSE IF WORD='EXIT' THEN CALL CASMEXIT; /*RAF-9*/ 00933140 ELSE IF WORD='NEXT' THEN CALL CASMNEXT; /*RAF-9*/ 00933150 ELSE IF WORD='GOTO' THEN CALL CASMGOTO; /*RAF-9*/ 00933160 ELSE CALL ERROR('CASM: '||WORD||' SHOULD NOT FOLLOW ASM');/*RAF-9*/ 00933170 /*RAF-9*/ 00933180 RETURN; /*RAF-9*/ 00933190 END; /*RAF-9*/ 00933200 1 00934000 /* ASMIF <CONDITION> THEN <STATEMENT> | 00935000 ASMIF <CONDITION> THEN <STATEMENT> ELSE <STATEMENT> */ 00936000 00937000 CASMIF: 00938000 PROCEDURE RECURSIVE ; 00939000 DECLARE 00940000 (GS1,GS2) CHAR(8) VARYING, 00941000 ELSEF BIT(1), 00942000 (L,ELEV) FIXED BIN, 00943000 CONDSTR CHAR(170) VARYING; 00944000 00945000 /* IF ^RCHAR('(') THEN */ /*RAF-9*/ 00946000 /* DO; */ /*RAF-9*/ 00947000 /* CALL ERROR('CASMIF: MISSING CONDITION CLAUSE.')*/ /*RAF-9*/ 00948000 /* RETURN; */ /*RAF-9*/ 00949000 /* END; */ /*RAF-9*/ 00950000 CONDSTR = CONDSCAN(#FALSE); /*RAF-9*/ 00951000 IF ^RCHECK('THEN') THEN 00952000 CALL ERROR('CASMIF: "THEN" INSERTED AFTER ")".'); 00953000 CALL LABPUSH; 00954000 CALL LABFLUSH; 00955000 GS1 = GENSEQSYM; 00956000 C_OPERATION = 'AIF'; 00957000 CONDSTR = '(NOT '||CONDSTR||')'||GS1; 00958000 GEN_OPERANDS(CONDSTR); 00959000 CALL ESQUISH; 00960000 ELEV = EQVLEV+1; 00961000 CALL STMNT; 00962000 CALL LABPUSH; 00963000 CALL LABFLUSH; 00964000 CALL EQVFLUSH(#FALSE,ELEV); 00965000 ELSEF = RCHECK('ELSE'); 00966000 IF ELSEF THEN 00967000 DO; 00968000 GS2 = GENSEQSYM; 00969000 GEN('AGO',GS2); 00970000 END; 00971000 CALL WLABEL(GS1); 00972000 IF ELSEF THEN 00973000 DO; 00974000 CALL ESQUISH; 00975000 ELEV = EQVLEV+1; 00976000 CALL STMNT; 00977000 CALL LABPUSH; 00978000 CALL LABFLUSH; 00979000 CALL EQVFLUSH(#FALSE,ELEV); 00980000 CALL WLABEL(GS2); 00981000 END; 00982000 GEN('ANOP',''); 00983000 RETURN; 00984000 /*RAF-8*/ 00984005 END CASMIF; /*RAF-8*/ 00984010 1 00984015 /* ASM CASE <SETA-VAR> ; */ /*RAF-9*/ 00984020 /* <ASM CASE-LIST> */ /*RAF-9*/ 00984025 /* ENDCASE */ /*RAF-9*/ 00984030 /*RAF-9*/ 00984035 CASMCASE: PROCEDURE RECURSIVE; /*RAF-9*/ 00984040 /*RAF-9*/ 00984045 DECLARE /*RAF-9*/ 00984050 (TCLABEL,NCLABEL,ECLABEL) CHAR(8) VARYING, /*RAF-25*/ /*RAF-9*/ 00984055 (SETVAR,CLOW) CHAR(170) VARYING; /*RAF-25*/ /*RAF-9*/ 00984060 /*RAF-9*/ 00984065 CALL ROPANDS(#FALSE); /* GET SET VARIABLE */ /*RAF-48*/ /*RAF-9*/ 00984070 IF OPANDS='' THEN DO; /*RAF-9*/ 00984075 CALL ERROR('CASMCASE-1: NO SET VARIABLE FOR ASM CASE');/*RAF-9*/ 00984080 OPANDS = '&X'; /*RAF-9*/ 00984085 END; /*RAF-9*/ 00984090 SETVAR = OPANDS; /*RAF-9*/ 00984095 /*RAF-9*/ 00984100 IF ^RCHAR(';') THEN /*RAF-9*/ 00984105 CALL ERROR('CASMCASE-2: MISSING SEMICOLON INSERTED'); /*RAF-9*/ 00984110 /*RAF-9*/ 00984115 ECLABEL = GENSEQSYM; /* END LABEL */ /*RAF-9*/ 00984120 TCLABEL = ''; /* THIS-CASE LABEL */ /*RAF-9*/ 00984125 NCLABEL = GENSEQSYM; /* NEXT-CASE LABEL */ /*RAF-9*/ 00984130 /*RAF-9*/ 00984135 ASMDOLEV = ASMDOLEV+1; /*RAF-9*/ 00984140 ASMDOID(ASMDOLEV) = NCLABEL; /* "NEXT" LABEL */ /*RAF-9*/ 00984145 ASMEXID(ASMDOLEV) = ''; /* "EXIT" LABEL */ /*RAF-9*/ 00984150 ASMDOLABEL(ASMDOLEV) = CURSEQSYM; /* "FROM/OF" LABEL */ /*RAF-9*/ 00984155 /*RAF-9*/ 00984160 NESTLEV = NESTLEV+1; /* INCREASE NESTING LEVEL */ /*RAF-9*/ 00984165 NESTID(NESTLEV) = CIN_ID; /*RAF-9*/ 00984170 /*RAF-9*/ 00984175 CALL LABPUSH; CALL LABFLUSH; /* CLEAR LABEL STACK */ /*RAF-9*/ 00984180 /*RAF-9*/ 00984185 CALL ROPANDS(#TRUE); /* SCAN FOR CASE LABEL */ /*RAF-9*/ 00984190 DO WHILE(OPANDS^='ENDCASE'); /* LOOP UNTIL ENDCASE */ /*RAF-9*/ 00984195 IF OPANDS='' THEN /*RAF-9*/ 00984200 CALL ERROR('CASMCASE-3: MISSING CASE LABEL'); /*RAF-9*/ 00984205 IF TCLABEL='' THEN DO; /*RAF-9*/ 00984210 TCLABEL = GENSEQSYM; /*RAF-9*/ 00984215 CALL CWLABEL(NCLABEL); /* LABEL THIS CASE */ /*RAF-9*/ 00984220 NCLABEL = GENSEQSYM; /* LABEL FOR NEXT CASE */ /*RAF-9*/ 00984225 END; /*RAF-9*/ 00984230 IF ^RCHECK('THRU') THEN DO; /* SINGLE CASE */ /*RAF-9*/ 00984235 GEN('AIF','('||SETVAR||' EQ '||OPANDS||')'|| /*RAF-9*/ 00984240 TCLABEL); /*RAF-9*/ 00984245 END; /*RAF-9*/ 00984250 ELSE DO; /*RAF-9*/ 00984255 CLOW = OPANDS; /*RAF-9*/ 00984260 CALL ROPANDS(#TRUE); /* GET HIGH VALUE */ /*RAF-9*/ 00984265 GEN('AIF','(('||SETVAR||' GE '||CLOW||') AND ('|| /*RAF-9*/ 00984270 SETVAR||' LE '||OPANDS||'))'||TCLABEL); /*RAF-9*/ 00984275 END; /*RAF-9*/ 00984280 IF RCHAR(',') THEN DO; /* MORE CASES */ /*RAF-9*/ 00984285 IF TCLABEL='' THEN /*RAF-9*/ 00984290 CALL ERROR('CASMCASE-4: EXTRANEOUS COMMA IGNORED'); /*RAF-9*/ 00984295 CALL ROPANDS(#TRUE); /* READ NEXT CASE VALUE */ /*RAF-9*/ 00984300 END; /*RAF-9*/ 00984305 ELSE IF RCHAR(':') THEN DO; /* BODY OF CASE */ /*RAF-9*/ 00984310 IF TCLABEL='' THEN DO; /*RAF-9*/ 00984315 CALL ERROR('CASMCASE-5: MISSING CASE LABEL'); /*RAF-9*/ 00984320 END; /*RAF-9*/ 00984325 GEN('AGO',NCLABEL); /* TRY NEXT CASE */ /*RAF-9*/ 00984330 CALL CWLABEL(TCLABEL); /* LABEL CASE BODY */ /*RAF-9*/ 00984335 CALL ASMSTMNT; /* GET A STATEMENT */ /*RAF-9*/ 00984340 GEN('AGO',ECLABEL); /* EXIT FROM CASE */ /*RAF-9*/ 00984345 TCLABEL = ''; /* INDICATE NO CASE */ /*RAF-9*/ 00984350 IF ^RCHAR(';') THEN /*RAF-9*/ 00984355 CALL ERROR('CASMCASE-6: MISSING SEMICOLON INSERTED' /*RAF-9*/ 00984360 ); /*RAF-9*/ 00984365 CALL ROPANDS(#TRUE); /* READ NEXT CASE VALUE */ /*RAF-9*/ 00984370 END; /*RAF-9*/ 00984375 ELSE DO; /*RAF-9*/ 00984380 CALL RWORD; CALL RCHAR(';'); /*RAF-9*/ 00984385 CALL ERROR('CASMCASE-7: EXTRANEOUS '||WORD|| /*RAF-9*/ 00984390 ' IGNORED'); /*RAF-9*/ 00984395 END; /*RAF-9*/ 00984400 END; /*RAF-9*/ 00984405 /*RAF-9*/ 00984410 NESTLEV = NESTLEV-1; /*RAF-25*/ 00984412 /*RAF-25*/ 00984413 CALL WLABEL(NCLABEL); /* NO MATCHING CASE */ /*RAF-9*/ 00984415 GEN('ANOP',''); /*RAF-23*/ 00984417 IF RCHECK('ELSE') THEN CALL ASMSTMNT; /*RAF-18*/ 00984418 ELSE GEN('MNOTE','4,''ASM CASE OUT OF RANGE''');/*RAF-9*//*RAF-18*/ 00984420 /*RAF-9*/ 00984425 CALL WLABEL(ECLABEL); /* ENDCASE LABEL */ /*RAF-9*/ 00984430 /*RAF-9*/ 00984435 ECLABEL = ASMEXID(ASMDOLEV); /*RAF-9*/ 00984440 ASMDOLEV = ASMDOLEV-1; /*RAF-9*/ 00984445 /* NESTLEV = NESTLEV-1; */ /*RAF-25*/ /*RAF-9*/ 00984450 IF NESTLEV=0 THEN PREDLABLEV=0; /*RAF-9*/ 00984455 IF RCHECK('THEN') THEN /*RAF-9*/ 00984460 CALL ASMSTMNT; /* GET A STATEMENT */ /*RAF-9*/ 00984465 /*RAF-9*/ 00984470 GEN('ANOP',''); /*RAF-22*/ 00984477 CALL CWLABEL(ECLABEL); /* "EXIT" LABEL */ /*RAF-9*/ 00984478 GEN('ANOP',''); /*RAF-35*/ 00984479 END CASMCASE; /*RAF-9*/ 00984480 1 00984485 /* ASM WHILE <COND> DO <STMNT> THEN <STMNT> */ /*RAF-9*/ 00984490 /* ASM UNTIL <COND> DO <STMNT> THEN <STMNT> */ /*RAF-9*/ 00984495 /*RAF-9*/ 00984500 CASMWHILE: PROCEDURE(UWB) RECURSIVE; /*RAF-9*/ 00984505 /*RAF-9*/ 00984510 DECLARE /*RAF-9*/ 00984515 UWB BIT(1), /* FALSE => WHILE */ /*RAF-9*/ 00984520 (TOP,FAILURE,THENPART) CHAR(8) VARYING; /*RAF-9*/ 00984525 /*RAF-9*/ 00984530 TOP = GENSEQSYM; /* TOP OF LOOP */ /*RAF-9*/ 00984535 FAILURE = GENSEQSYM; /* END LABEL */ /*RAF-9*/ 00984540 /*RAF-9*/ 00984545 ASMDOLEV = ASMDOLEV+1; /*RAF-9*/ 00984550 ASMDOID(ASMDOLEV) = TOP; /* "NEXT" LABEL */ /*RAF-9*/ 00984555 ASMEXID(ASMDOLEV) = ''; /* "EXIT" LABEL */ /*RAF-9*/ 00984560 ASMDOLABEL(ASMDOLEV) = CURSEQSYM; /* "FROM" LABEL */ /*RAF-9*/ 00984565 /*RAF-9*/ 00984570 CALL LABPUSH; CALL LABFLUSH; /* FLUSH LABEL STACK */ /*RAF-9*/ 00984575 /*RAF-9*/ 00984580 CALL WLABEL(TOP); /*RAF-9*/ 00984585 IF UWB /*RAF-9*/ 00984590 THEN GEN('AIF',CONDSCAN(#FALSE)||FAILURE); /* UNTIL */ /*RAF-9*/ 00984595 ELSE GEN('AIF','(NOT '||CONDSCAN(#FALSE)||')'||FAILURE); /*RAF-9*/ 00984600 /*RAF-9*/ 00984605 IF ^RCHECK('DO') THEN /*RAF-9*/ 00984610 CALL ERROR('CASMWHILE/UNTIL: MISSING "DO" INSERTED'); /*RAF-9*/ 00984615 /*RAF-9*/ 00984620 CALL ASMSTMNT; /* GET A STATEMENT */ /*RAF-9*/ 00984625 /*RAF-9*/ 00984630 GEN('AGO',TOP); /*RAF-9*/ 00984635 CALL WLABEL(FAILURE); /*RAF-9*/ 00984640 /*RAF-9*/ 00984645 THENPART = ASMEXID(ASMDOLEV); /*RAF-9*/ 00984650 ASMDOLEV = ASMDOLEV-1; /*RAF-9*/ 00984655 IF RCHECK('THEN') THEN CALL ASMSTMNT; /*RAF-9*/ 00984660 /*RAF-9*/ 00984665 CALL CWLABEL(THENPART); /*RAF-9*/ 00984670 GEN('ANOP',''); /*RAF-22*/ 00984672 /*RAF-9*/ 00984675 RETURN; /*RAF-9*/ 00984680 END CASMWHILE; /*RAF-9*/ 00984685 1 00984690 /* ASM FOR <SETA-VAR> FROM <SETA-EXPR> BY <SETA-EXPR> */ /*RAF-9*/ 00984695 /* TO <SETA-EXPR> DO <STMNT> THEN <STMNT> */ /*RAF-9*/ 00984700 /*RAF-9*/ 00984705 CASMFOR: PROCEDURE RECURSIVE; /*RAF-9*/ 00984710 /*RAF-9*/ 00984715 DECLARE /*RAF-9*/ 00984720 VAR CHAR(8) VARYING, /*RAF-9*/ 00984725 (FROMVAL,BYVAL,TOVAL) CHAR(170) VARYING, /*RAF-9*/ 00984730 (TOP,DONE,THENPART) CHAR(8) VARYING; /*RAF-9*/ 00984735 /*RAF-9*/ 00984740 TOP = GENSEQSYM; /*RAF-9*/ 00984745 DONE = GENSEQSYM; /*RAF-9*/ 00984750 ASMDOLEV = ASMDOLEV+1; /*RAF-9*/ 00984755 ASMDOID(ASMDOLEV) = ''; /*RAF-9*/ 00984760 ASMEXID(ASMDOLEV) = ''; /*RAF-9*/ 00984765 ASMDOLABEL(ASMDOLEV) = CURSEQSYM; /*RAF-9*/ 00984770 /*RAF-9*/ 00984775 CALL RLABEL; /* GET SETA VARIABLE */ /*RAF-9*/ 00984780 IF WORD^='' THEN DO; /*RAF-9*/ 00984785 IF SUBSTR(WORD,1,1)^='&' THEN /*RAF-9*/ 00984790 CALL ERROR('CASMFOR-1: ILLEGAL SETA VARIABLE'); /*RAF-9*/ 00984795 VAR = WORD; /*RAF-9*/ 00984800 END; /*RAF-9*/ 00984805 ELSE DO; /*RAF-9*/ 00984810 CALL ERROR('CASMFOR-2: MISSING SETA VARIABLE'); /*RAF-9*/ 00984815 VAR = '&X'; /*RAF-9*/ 00984820 END; /*RAF-9*/ 00984825 /*RAF-9*/ 00984830 FROMVAL = '0'; BYVAL = '1'; TOVAL = ''; /* DEFAULTS */ /*RAF-9*/ 00984835 DO WHILE(#TRUE); /*RAF-9*/ 00984840 IF RCHECK('DO') THEN GO TO DO_FOUND; /*RAF-9*/ 00984845 IF RCHECK('FROM') THEN DO; /*RAF-9*/ 00984850 CALL ROPANDS(#TRUE); /*RAF-9*/ 00984855 IF OPANDS='' THEN /*RAF-9*/ 00984860 CALL ERROR('CASMFOR-3: MISSING "FROM" VALUE'); /*RAF-9*/ 00984865 ELSE FROMVAL = OPANDS; /*RAF-9*/ 00984870 END; /*RAF-9*/ 00984875 ELSE IF RCHECK('BY') THEN DO; /*RAF-9*/ 00984880 CALL ROPANDS(#TRUE); /*RAF-9*/ 00984885 IF OPANDS='' THEN /*RAF-9*/ 00984890 CALL ERROR('CASMFOR-4: MISSING "BY" VALUE'); /*RAF-9*/ 00984895 ELSE BYVAL = OPANDS; /*RAF-9*/ 00984900 END; /*RAF-9*/ 00984905 ELSE IF RCHECK('TO') THEN DO; /*RAF-9*/ 00984910 CALL ROPANDS(#TRUE); /*RAF-9*/ 00984915 IF OPANDS='' THEN /*RAF-9*/ 00984920 CALL ERROR('CASMFOR-5: MISSING "TO" VALUE'); /*RAF-9*/ 00984925 ELSE TOVAL = OPANDS; /*RAF-9*/ 00984930 END; /*RAF-9*/ 00984935 ELSE DO; /*RAF-9*/ 00984940 CALL ERROR('CASMFOR: MISSING "DO" INSERTED'); /*RAF-9*/ 00984945 GO TO DO_FOUND; /*RAF-9*/ 00984950 END; /*RAF-9*/ 00984955 END; /*RAF-9*/ 00984960 DO_FOUND: /*RAF-9*/ 00984965 /*RAF-9*/ 00984970 CALL LABPUSH; CALL LABFLUSH; /*RAF-9*/ 00984975 CALL WLABEL(VAR); /*RAF-9*/ 00984980 GEN('SETA',FROMVAL); /*RAF-9*/ 00984985 CALL WLABEL(TOP); /*RAF-9*/ 00984990 IF TOVAL^='' THEN DO; /*RAF-9*/ 00984995 GEN('AIF','(('||BYVAL||' GT 0) AND ('||VAR||' GT '|| /*RAF-9*/ 00985000 TOVAL||'))'||DONE); /*RAF-9*/ 00985005 GEN('AIF','(('||BYVAL||' LT 0) AND ('||VAR||' LT '|| /*RAF-9*/ 00985010 TOVAL||'))'||DONE); /*RAF-9*/ 00985015 END; /*RAF-9*/ 00985020 CALL ASMSTMNT; /*RAF-9*/ 00985025 CALL CWLABEL(ASMDOID(ASMDOLEV)); /*RAF-9*/ 00985030 CALL WLABEL(VAR); /*RAF-9*/ 00985035 GEN('SETA',VAR||'+'||BYVAL); /*RAF-9*/ 00985040 GEN('AGO',TOP); /*RAF-9*/ 00985045 CALL WLABEL(DONE); /*RAF-9*/ 00985050 GEN('ANOP',''); /*RAF-35*/ 00985052 /*RAF-9*/ 00985055 THENPART = ASMEXID(ASMDOLEV); /*RAF-9*/ 00985060 ASMDOLEV = ASMDOLEV-1; /*RAF-9*/ 00985065 IF RCHECK('THEN') THEN CALL ASMSTMNT; /*RAF-9*/ 00985070 CALL CWLABEL(THENPART); /*RAF-9*/ 00985075 IF THENPART^='' THEN GEN('ANOP',''); /*RAF-27*/ /*RAF-22*/ 00985077 /*RAF-9*/ 00985080 RETURN; /*RAF-9*/ 00985085 END CASMFOR; /*RAF-9*/ 00985090 1 00985095 /* ASM FOREVER DO <STMNT> */ /*RAF-9*/ 00985100 /*RAF-9*/ 00985105 CASMFOREVER: PROCEDURE RECURSIVE; /*RAF-9*/ 00985110 /*RAF-9*/ 00985115 DECLARE TOP CHAR(8) VARYING; /*RAF-9*/ 00985120 /*RAF-9*/ 00985125 IF ^RCHECK('DO') THEN /*RAF-9*/ 00985130 CALL ERROR('CASMFOREVER-1: MISSING "DO" INSERTED'); /*RAF-9*/ 00985135 /*RAF-9*/ 00985140 TOP = GENSEQSYM; /*RAF-9*/ 00985145 /*RAF-9*/ 00985150 ASMDOLEV = ASMDOLEV+1; /*RAF-9*/ 00985155 ASMDOID(ASMDOLEV) = TOP; /*RAF-9*/ 00985160 ASMEXID(ASMDOLEV) = ''; /*RAF-9*/ 00985165 ASMDOLABEL(ASMDOLEV) = CURSEQSYM; /*RAF-9*/ 00985170 /*RAF-9*/ 00985175 CALL LABPUSH; CALL LABFLUSH; /*RAF-9*/ 00985180 /*RAF-9*/ 00985185 CALL WLABEL(TOP); /*RAF-9*/ 00985190 CALL ASMSTMNT; /*RAF-9*/ 00985195 GEN('AGO',TOP); /*RAF-9*/ 00985200 /*RAF-9*/ 00985205 IF RCHECK('THEN') THEN /*RAF-9*/ 00985210 CALL ERROR('CASMFOREVER-2: IAPPROPRIATE "THEN" IGNORED'); /*RAF-9*/ 00985215 /*RAF-9*/ 00985220 CALL CWLABEL(ASMEXID(ASMDOLEV)); /* "EXIT" LABEL */ /*RAF-9*/ 00985225 GEN('ANOP',''); /*RAF-22*/ 00985227 ASMDOLEV = ASMDOLEV-1; /*RAF-9*/ 00985230 RETURN; /*RAF-9*/ 00985235 END CASMFOREVER; /*RAF-9*/ 00985240 1 00985245 /* ASM DO <STMNT> THEN <STMNT> */ /*RAF-9*/ 00985250 /* ASM DO <STMNT> WHILE/UNTIL <COND> THEN <STMNT> */ /*RAF-9*/ 00985255 /* ASM DO <STMNT> FOR <SETA-VAR> BY <SETA-EXPR> */ /*RAF-9*/ 00985260 /* TO <SETA-EXPR> THEN <STMNT> */ /*RAF-9*/ 00985265 /* ASM DO <STMNT> FOREVER */ /*RAF-9*/ 00985270 /*RAF-9*/ 00985275 CASMDO: PROCEDURE RECURSIVE; /*RAF-9*/ 00985280 /*RAF-9*/ 00985285 DECLARE /*RAF-9*/ 00985290 (TOP,EXIT) CHAR(8) VARYING, /*RAF-9*/ 00985295 THENOK BIT(1) INIT(#TRUE); /*RAF-9*/ 00985300 /*RAF-9*/ 00985305 TOP = GENSEQSYM; /* TOP OF LOOP LABEL */ /*RAF-9*/ 00985310 /*RAF-9*/ 00985315 ASMDOLEV = ASMDOLEV+1; /*RAF-9*/ 00985320 ASMDOID(ASMDOLEV),ASMEXID(ASMDOLEV) = ''; /*RAF-9*/ 00985325 ASMDOLABEL(ASMDOLEV) = CURSEQSYM; /*RAF-9*/ 00985330 /*RAF-9*/ 00985335 CALL LABPUSH; CALL LABFLUSH; /*RAF-9*/ 00985340 CALL WLABEL(TOP); /* LABEL TOP OF LOOP */ /*RAF-9*/ 00985345 CALL ASMSTMNT; /* GET BODY OF LOOP */ /*RAF-9*/ 00985350 CALL CWLABEL(ASMDOID(ASMDOLEV)); /* "NEXT" LABEL */ /*RAF-9*/ 00985355 /*RAF-9*/ 00985360 IF RCHECK('WHILE') THEN DO; /*RAF-9*/ 00985365 GEN('AIF',CONDSCAN(#FALSE)||TOP); /*RAF-9*/ 00985370 END; /*RAF-9*/ 00985375 ELSE IF RCHECK('UNTIL') THEN DO; /*RAF-9*/ 00985380 GEN('AIF','(NOT '||CONDSCAN(#FALSE)||')'||TOP); /*RAF-9*/ 00985385 END; /*RAF-9*/ 00985390 ELSE IF RCHECK('FOREVER') THEN DO; /*RAF-9*/ 00985395 GEN('AGO',TOP); /*RAF-9*/ 00985400 THENOK = #FALSE; /*RAF-9*/ 00985405 END; /*RAF-9*/ 00985410 ELSE IF RCHECK('FOR') THEN BEGIN; /*RAF-9*/ 00985415 DECLARE /*RAF-9*/ 00985420 VAR CHAR(8) VARYING, /*RAF-9*/ 00985425 (BYVAL,TOVAL) CHAR(170) VARYING; /*RAF-9*/ 00985430 CALL RLABEL; /* GET SETA VARIABLE */ /*RAF-9*/ 00985435 IF WORD^='' THEN DO; /*RAF-9*/ 00985440 IF SUBSTR(WORD,1,1)^='&' THEN /*RAF-9*/ 00985445 CALL ERROR('CASMDO-1: ILLEGAL SETA VARIABLE'); /*RAF-9*/ 00985450 VAR = WORD; /*RAF-9*/ 00985455 END; /*RAF-9*/ 00985460 ELSE DO; /*RAF-9*/ 00985465 CALL ERROR('CASMDO-2: MISSING SETA VARIABLE'); /*RAF-9*/ 00985470 VAR = '&X'; /*RAF-9*/ 00985475 END; /*RAF-9*/ 00985480 BYVAL = '1'; TOVAL=''; /*RAF-9*/ 00985485 DO WHILE(#TRUE); /*RAF-9*/ 00985490 IF RCHECK('FROM') THEN DO; /*RAF-9*/ 00985495 CALL ERROR('CASMFOR-3: INAPPROPRIATE "FROM"'|| /*RAF-9*/ 00985500 ' IGNORED'); /*RAF-9*/ 00985505 END; /*RAF-9*/ 00985510 ELSE IF RCHECK('BY') THEN DO; /*RAF-9*/ 00985515 CALL ROPANDS(#TRUE); /*RAF-9*/ 00985520 IF OPANDS='' THEN /*RAF-9*/ 00985525 CALL ERROR('CASMDO-4: MISSING "BY" VALUE'); /*RAF-9*/ 00985530 ELSE BYVAL = OPANDS; /*RAF-9*/ 00985535 END; /*RAF-9*/ 00985540 ELSE IF RCHECK('TO') THEN DO; /*RAF-9*/ 00985545 CALL ROPANDS(#TRUE); /*RAF-9*/ 00985550 IF OPANDS='' THEN /*RAF-9*/ 00985555 CALL ERROR('CASMDO-5: MISSING "TO" VALUE'); /*RAF-9*/ 00985560 ELSE TOVAL = OPANDS; /*RAF-9*/ 00985565 END; /*RAF-9*/ 00985570 ELSE DO; /*RAF-9*/ 00985575 GO TO NO_BY_OR_TO; /*RAF-9*/ 00985580 END; /*RAF-9*/ 00985585 END; /*RAF-9*/ 00985590 NO_BY_OR_TO: /*RAF-9*/ 00985595 /*RAF-9*/ 00985600 CALL WLABEL(VAR); /*RAF-9*/ 00985605 GEN('SETA',VAR||'+'||BYVAL); /*RAF-9*/ 00985610 IF TOVAL^='' THEN DO; /*RAF-9*/ 00985615 GEN('AIF','(('||BYVAL||' GT 0) AND ('||VAR|| /*RAF-9*/ 00985620 ' LE '||TOVAL||'))'||TOP); /*RAF-9*/ 00985625 GEN('AIF','(('||BYVAL||' LT 0) AND ('||VAR|| /*RAF-9*/ 00985630 ' GE '||TOVAL||'))'||TOP); /*RAF-9*/ 00985635 END; /*RAF-9*/ 00985640 ELSE GEN('AGO',TOP); /*RAF-9*/ 00985645 END; /*RAF-9*/ 00985650 /*RAF-9*/ 00985655 EXIT = ASMEXID(ASMDOLEV); /*RAF-9*/ 00985660 ASMDOLEV=ASMDOLEV-1; /*RAF-9*/ 00985665 IF RCHECK('THEN') THEN DO; /*RAF-9*/ 00985670 IF ^THENOK THEN /*RAF-9*/ 00985675 CALL ERROR('CASMDO-6: INAPPROPRIATE "THEN" IGNORED'); /*RAF-9*/ 00985680 CALL ASMSTMNT; /*RAF-9*/ 00985685 END; /*RAF-9*/ 00985690 CALL CWLABEL(EXIT); /*RAF-9*/ 00985695 GEN('ANOP',''); /*RAF-22*/ 00985697 /*RAF-9*/ 00985700 RETURN; /*RAF-9*/ 00985705 END CASMDO; /*RAF-9*/ 00985710 1 00985715 /* ASM SELECT (FIRST) */ /*RAF-9*/ 00985720 /* <COND>: STMNT; ... */ /*RAF-9*/ 00985725 /* ENDSEL (ELSE STMNT) (THEN STMNT) */ /*RAF-9*/ 00985730 /*RAF-9*/ 00985735 CASMSELECT: PROCEDURE RECURSIVE; /*RAF-9*/ 00985740 /*RAF-9*/ 00985745 DECLARE /*RAF-9*/ 00985750 (THENPART,NEXTCASE,EXIT) CHAR(8) VARYING, /*RAF-9*/ 00985755 FIRST BIT(1); /*RAF-9*/ 00985760 /*RAF-9*/ 00985765 NESTLEV = NESTLEV+1; /*RAF-9*/ 00985770 NESTID(NESTLEV) = CIN_ID; /*RAF-9*/ 00985775 /*RAF-9*/ 00985780 FIRST = RCHECK('FIRST'); /*RAF-9*/ 00985785 IF ^RCHAR(';') THEN /*RAF-9*/ 00985790 CALL ERROR('CASMSELECT-1: MISSING SEMICOLON INSERTED'); /*RAF-9*/ 00985795 /*RAF-9*/ 00985800 THENPART = GENSEQSYM; /*RAF-9*/ 00985805 NEXTCASE = GENSEQSYM; /*RAF-9*/ 00985810 EXIT = ''; /*RAF-9*/ 00985815 IF FIRST THEN EXIT = GENSEQSYM; /*RAF-9*/ 00985820 /*RAF-9*/ 00985825 ASMDOLEV = ASMDOLEV+1; /*RAF-9*/ 00985830 ASMDOID(ASMDOLEV) = NEXTCASE; /*RAF-9*/ 00985835 ASMEXID(ASMDOLEV) = EXIT; /*RAF-9*/ 00985840 ASMDOLABEL(ASMDOLEV) = CURSEQSYM; /*RAF-9*/ 00985845 /*RAF-9*/ 00985850 CALL LABPUSH; CALL LABFLUSH; /*RAF-9*/ 00985855 /*RAF-9*/ 00985860 DO WHILE(^RCHECK('ENDSEL')); /*RAF-9*/ 00985865 CALL WLABEL(NEXTCASE); /*RAF-9*/ 00985870 NEXTCASE = GENSEQSYM; /*RAF-9*/ 00985875 GEN('AIF','(NOT '||CONDSCAN(#FALSE)||')'||NEXTCASE); /*RAF-9*/ 00985880 IF ^RCHAR(':') THEN /*RAF-9*/ 00985885 CALL ERROR('CASMSELECT-2: MISSING COLON INSERTED'); /*RAF-9*/ 00985890 CALL ASMSTMNT; /*RAF-9*/ 00985895 IF ^RCHAR(';') THEN /*RAF-9*/ 00985900 CALL ERROR('CASMSELECT-4: MISSING SEMICOLON INSERTED');/*RAF-9*/ 00985905 IF FIRST THEN GEN('AGO',EXIT); /*RAF-9*/ 00985910 END; /*RAF-9*/ 00985915 /*RAF-9*/ 00985920 CALL WLABEL(NEXTCASE); /*RAF-9*/ 00985925 NESTLEV = NESTLEV - 1; /*RAF-9*/ 00985930 /*RAF-9*/ 00985935 IF RCHECK('ELSE') THEN DO; /*RAF-9*/ 00985940 IF ^FIRST THEN /*RAF-9*/ 00985945 CALL ERROR('CASMSELECT-3: ELSE USED WITHOUT FIRST'); /*RAF-9*/ 00985950 CALL ASMSTMNT; /*RAF-9*/ 00985955 END; /*RAF-9*/ 00985960 /*RAF-9*/ 00985965 EXIT = ASMEXID(ASMDOLEV); /*RAF-9*/ 00985970 ASMDOLEV = ASMDOLEV - 1; /*RAF-9*/ 00985975 CALL WLABEL(THENPART); /*RAF-9*/ 00985980 IF RCHECK('THEN') THEN CALL ASMSTMNT; /*RAF-9*/ 00985985 CALL CWLABEL(EXIT); /*RAF-9*/ 00985990 GEN('ANOP',''); /*RAF-22*/ 00985992 RETURN; /*RAF-9*/ 00985995 END CASMSELECT; /*RAF-9*/ 00986000 1 00986005 /* ASM EXIT FROM <SEQSYM> IF <COND> */ /*RAF-9*/ 00986010 /*RAF-9*/ 00986015 CASMEXIT: PROCEDURE; /*RAF-9*/ 00986020 /*RAF-9*/ 00986025 DECLARE /*RAF-9*/ 00986030 EXLABEL CHAR(8) VARYING, /*RAF-9*/ 00986035 I FIXED BIN; /*RAF-9*/ 00986040 /*RAF-9*/ 00986045 EXLABEL=''; /*RAF-9*/ 00986050 IF ASMDOLEV<=0 THEN /*RAF-9*/ 00986055 CALL ERROR('CASMEXIT-1: NO CONTAINING ASM LOOP'|| /*RAF-9*/ 00986060 ' STRUCTURE FOR ASM EXIT'); /*RAF-9*/ 00986065 IF ^RCHECK('FROM') THEN I=ASMDOLEV; /*RAF-9*/ 00986070 ELSE DO; /*RAF-9*/ 00986075 CALL RLABEL; /*RAF-9*/ 00986080 IF WORD='' THEN /*RAF-9*/ 00986085 CALL ERROR('CASMEXIT-2: MISSING SEQUENCE SYMBOL'|| /*RAF-9*/ 00986090 ' FOLLOWING "FROM"'); /*RAF-9*/ 00986095 ELSE IF SUBSTR(WORD,1,1)^='.' THEN /*RAF-9*/ 00986100 CALL ERROR('CASMEXIT-3: EXIT LABEL MUST BE '|| /*RAF-9*/ 00986105 'SEQUENCE SYMBOL'); /*RAF-9*/ 00986110 DO I=ASMDOLEV BY -1 TO 1 /*RAF-9*/ 00986115 WHILE(ASMDOLABEL(I)^=WORD); /*RAF-9*/ 00986120 END; /*RAF-9*/ 00986125 IF I<1 THEN DO; /*RAF-9*/ 00986130 CALL ERROR('CASMEXIT-4: EXIT LABEL NOT FOUND'); /*RAF-9*/ 00986135 I = ASMDOLEV; /*RAF-9*/ 00986140 END; /*RAF-9*/ 00986145 END; /*RAF-9*/ 00986150 IF I>=1 THEN DO; /*RAF-9*/ 00986155 IF ASMEXID(I)='' THEN ASMEXID(I) = GENSEQSYM; /*RAF-9*/ 00986160 EXLABEL = ASMEXID(I); /*RAF-9*/ 00986165 END; /*RAF-9*/ 00986170 /*RAF-9*/ 00986175 CALL LABPUSH; CALL LABFLUSH; /*RAF-31*/ 00986178 IF ^RCHECK('IF') THEN GEN('AGO',EXLABEL); /*RAF-9*/ 00986180 ELSE DO; /*RAF-9*/ 00986185 OPANDS=CONDSCAN(#FALSE); /*RAF-9*/ 00986190 GEN('AIF',OPANDS||EXLABEL); /*RAF-9*/ 00986195 END; /*RAF-9*/ 00986200 /*RAF-9*/ 00986205 RETURN; /*RAF-9*/ 00986210 END CASMEXIT; /*RAF-9*/ 00986215 1 00986220 /* ASM NEXT OF <SEQSYM> IF <COND> */ /*RAF-9*/ 00986225 /*RAF-9*/ 00986230 CASMNEXT: PROCEDURE; /*RAF-9*/ 00986235 /*RAF-9*/ 00986240 DECLARE /*RAF-9*/ 00986245 NXLABEL CHAR(8) VARYING, /*RAF-9*/ 00986250 I FIXED BIN; /*RAF-9*/ 00986255 /*RAF-9*/ 00986260 NXLABEL=''; /*RAF-9*/ 00986265 IF ASMDOLEV<=0 THEN /*RAF-9*/ 00986270 CALL ERROR('CASMNEXT-1: NO CONTAINING ASM LOOP'|| /*RAF-9*/ 00986275 ' STRUCTURE FOR ASM NEXT'); /*RAF-9*/ 00986280 IF ^RCHECK('OF') THEN I=ASMDOLEV; /*RAF-9*/ 00986285 ELSE DO; /*RAF-9*/ 00986290 CALL RLABEL; /*RAF-9*/ 00986295 IF WORD='' THEN /*RAF-9*/ 00986300 CALL ERROR('CASMNEXT-2: MISSING SEQUENCE SYMBOL'|| /*RAF-9*/ 00986305 ' FOLLOWING "OF"'); /*RAF-9*/ 00986310 ELSE IF SUBSTR(WORD,1,1)^='.' THEN /*RAF-9*/ 00986315 CALL ERROR('CASMNEXT-3: NEXT LABEL MUST BE '|| /*RAF-9*/ 00986320 'SEQUENCE SYMBOL'); /*RAF-9*/ 00986325 DO I=ASMDOLEV BY -1 TO 1 /*RAF-9*/ 00986330 WHILE(ASMDOLABEL(I)^=WORD); /*RAF-9*/ 00986335 END; /*RAF-9*/ 00986340 IF I<1 THEN DO; /*RAF-9*/ 00986345 CALL ERROR('CASMNEXT-4: NEXT LABEL NOT FOUND'); /*RAF-9*/ 00986350 I = ASMDOLEV; /*RAF-9*/ 00986355 END; /*RAF-9*/ 00986360 END; /*RAF-9*/ 00986365 IF I>=1 THEN DO; /*RAF-9*/ 00986370 IF ASMDOID(I)='' THEN ASMDOID(I) = GENSEQSYM; /*RAF-9*/ 00986375 NXLABEL = ASMDOID(I); /*RAF-9*/ 00986380 END; /*RAF-9*/ 00986385 /*RAF-9*/ 00986390 CALL LABPUSH; CALL LABFLUSH; /*RAF-31*/ 00986393 IF ^RCHECK('IF') THEN GEN('AGO',NXLABEL); /*RAF-9*/ 00986395 ELSE DO; /*RAF-9*/ 00986400 OPANDS=CONDSCAN(#FALSE); /*RAF-9*/ 00986405 GEN('AIF',OPANDS||NXLABEL); /*RAF-9*/ 00986410 END; /*RAF-9*/ 00986415 /*RAF-9*/ 00986420 RETURN; /*RAF-9*/ 00986425 END CASMNEXT; /*RAF-9*/ 00986430 1 00986435 /* ASM GOTO <SEQSYM> IF <COND> */ /*RAF-9*/ 00986440 /*RAF-9*/ 00986445 CASMGOTO: PROCEDURE; /*RAF-9*/ 00986450 /*RAF-9*/ 00986455 DECLARE LABEL CHAR(8) VARYING STATIC; /*RAF-9*/ 00986460 /*RAF-9*/ 00986465 CALL RLABEL; /*RAF-9*/ 00986470 LABEL = WORD; /*RAF-9*/ 00986475 IF LABEL = '' /*RAF-9*/ 00986480 THEN CALL ERROR('CASMGOTO-1: MISSING SEQUENCE SYMBOL'); /*RAF-9*/ 00986485 ELSE IF SUBSTR(LABEL,1,1)^='.' /*RAF-9*/ 00986490 THEN CALL ERROR('CASMGOTO-2: ILLEGAL SEQUENCE SYMBOL'); /*RAF-9*/ 00986495 /*RAF-9*/ 00986500 CALL LABPUSH; CALL LABFLUSH; /*RAF-9*/ 00986505 /*RAF-9*/ 00986510 IF RCHECK('IF') /*RAF-9*/ 00986515 THEN GEN('AIF',CONDSCAN(#FALSE)||LABEL); /*RAF-9*/ 00986520 ELSE GEN('AGO',LABEL); /*RAF-9*/ 00986525 /*RAF-9*/ 00986530 RETURN; /*RAF-9*/ 00986535 END CASMGOTO; /*RAF-9*/ 00986540 1 00986545 ESQUISH: /*RAF-9*/ 00986550 PROCEDURE; 00987000 DCL 00988000 (I,J) FIXED BIN; 00989000 00990000 J = 0; 00991000 DO I = 1 TO EQVLEV; 00992000 IF EQVSTK(I,1) ^= '' THEN 00993000 DO; 00994000 J = J+1; 00995000 EQVSTK(J,1) = EQVSTK(I,1); 00996000 EQVSTK(J,2) = EQVSTK(I,2); 00997000 END; 00998000 END; 00999000 EQVLEV = J; 01000000 RETURN; 01001000 END ESQUISH; 01002000 01003000 /* END CASMIF; */ /*RAF-8*/ 01004000 1 01004010 /* PROCEDURE TO FIND LABEL FOR ASM LOOP CONSTRUCT */ /*RAF-9*/ 01004020 /*RAF-9*/ 01004030 CURSEQSYM: PROCEDURE RETURNS(CHAR(8) VARYING); /*RAF-9*/ 01004040 /*RAF-9*/ 01004050 DECLARE CLABEL CHAR(8) VARYING; /*RAF-9*/ 01004060 /*RAF-9*/ 01004070 CLABEL = ''; /*RAF-9*/ 01004080 IF SUBSTR(C_LABEL,1,1)='.' & SUBSTR(C_LABEL,2,1)^='@' /*RAF-9*/ 01004090 THEN CLABEL = C_LABEL; /*RAF-9*/ 01004100 ELSE IF C_LABEL=' ' & LABLEV>0 THEN DO; /*RAF-9*/ 01004110 IF SUBSTR(LABSTK(LABLEV),1,1)='.' & /*RAF-9*/ 01004120 SUBSTR(LABSTK(LABLEV),2,1)^='@' /*RAF-9*/ 01004130 THEN CLABEL = LABSTK(LABLEV); /*RAF-9*/ 01004140 END; /*RAF-9*/ 01004150 /*RAF-9*/ 01004160 RETURN(CLABEL); /*RAF-9*/ 01004170 END CURSEQSYM; /*RAF-9*/ 01004180 1 01004190 /* PROCEDURE TO SCAN FOR STATEMENT IN ASM CONSTRUCT */ /*RAF-9*/ 01004200 /*RAF-9*/ 01004210 ASMSTMNT: PROCEDURE RECURSIVE; /*RAF-9*/ 01004220 /*RAF-9*/ 01004230 DCL ELEV FIXED BIN; /*RAF-9*/ 01004240 /*RAF-9*/ 01004250 CALL ESQUISH; /*RAF-9*/ 01004260 ELEV = EQVLEV+1; /*RAF-9*/ 01004270 CALL STMNT; /*RAF-9*/ 01004280 CALL LABPUSH; /*RAF-9*/ 01004290 CALL LABFLUSH; /*RAF-9*/ 01004300 CALL EQVFLUSH(#FALSE,ELEV); /*RAF-9*/ 01004310 END ASMSTMNT; /*RAF-9*/ 01004320 1 01005000 /* MACRO (&L:) <MACRO NAME> (<PARAMETER LIST>); 01006000 <BODY> 01007000 MEND */ 01008000 01009000 CMACRO: PROCEDURE; 01010000 DCL 01011000 (MLABEL,MNAME) CHAR(8) VARYING, 01012000 (I,L,ELEV) FIXED BIN, /*RAF-8*/ 01013000 DEFTYPE CHAR(8) VARYING, DEFS(7) CHAR(8) VAR 01014000 INIT('GBLA','GBLB','GBLC','LCLA','LCLB','LCLC','COPY'); 01015000 01016000 IN_MACRO = #TRUE; 01017000 MLABEL = ''; 01018000 IF RCHAR('&') THEN 01019000 DO; 01020000 IF ^RCHAR('&') THEN 01021000 CALL ERROR('CMACRO: "&" INSERTED.'); 01022000 CALL RWORD; 01023000 IF WORDAL THEN 01024000 MLABEL = '&'||WORD; 01025000 ELSE 01026000 CALL ERROR('CMACRO: INVALID MACRO LABEL.'); 01027000 IF ^RCHAR(':') THEN 01028000 CALL ERROR('CMACRO: ":" ASSUMED AFTER "'|| 01029000 MLABEL||'".'); 01030000 END; 01031000 CALL RWORD; 01032000 IF WORDAL THEN 01033000 MNAME = WORD; 01034000 ELSE 01035000 DO; 01036000 MNAME = '???'; 01037000 CALL ERROR('CMACRO: MISSING MACRO NAME.'); 01038000 END; 01039000 CALL ROPANDS(#FALSE); /*RAF-9*/ 01040000 IF ^RCHAR(';') THEN 01041000 CALL ERROR('CMACRO: MISSING SEMICOLON INSERTED.'); 01042000 CALL LABPUSH; 01043000 C_DATA = ' '; 01044000 GEN('MACRO',''); 01045000 C_LABEL = MLABEL; 01046000 C_OPERATION = MNAME; 01047000 GEN_OPERANDS(OPANDS); 01048000 1 01049000 NESTLEV = NESTLEV+1; 01050000 NESTID(NESTLEV) = CIN_ID; 01051000 DEFTYPE = '?'; 01052000 DO WHILE(DEFTYPE^=''); 01053000 DEFTYPE = ''; 01054000 DO I=1 TO 7 WHILE(^RCHECK(DEFS(I))); 01055000 END; 01056000 IF I<8 THEN 01057000 DO; 01058000 DEFTYPE,WORD = DEFS(I); 01059000 CALL ALCSTMT; 01060000 IF ^RCHAR(';') THEN 01061000 CALL ERROR('CMACRO: MISSING SEMICOLON INSERTED.'); 01062000 END; 01063000 END; 01064000 GEN('LCLC','&@'); 01065000 C_LABEL = '&@'; 01066000 GEN('SETC','''&SYSNDX'''); 01067000 CALL ESQUISH; /*RAF-8*/ 01067100 ELEV = EQVLEV+1; /*RAF-8*/ 01067200 DO WHILE(IN_MACRO); 01068000 IF RCHECK('MEND') THEN IN_MACRO = #FALSE; /*RAF-8*/ 01068100 ELSE IF RCHECK('ENDMACRO') THEN IN_MACRO = #FALSE; /*RAF-8*/ 01068200 ELSE DO; /*RAF-8*/ 01069000 CALL STMNT; /*RAF-8*/ 01070000 IF ^RCHAR(';') THEN 01071000 CALL ERROR('CMACRO: MISSING SEMICOLON INSERTED.'); 01072000 END; /*RAF-8*/ 01072500 END; 01073000 NESTLEV = NESTLEV-1; 01074000 IF NESTLEV=0 THEN PREDLABLEV=0; /*RAF-6*/ 01074500 CALL LABPUSH; /*RAF-8*/ 01074600 CALL LABFLUSH; /*RAF-8*/ 01074700 CALL EQVFLUSH(#FALSE,ELEV); /*RAF-8*/ 01074800 GEN('MEND',''); /*RAF-8*/ 01074900 RETURN; 01075000 END CMACRO; 01076000 1 01077000 /* BAL; 01078000 <BAL CODING> 01079000 ALP; */ 01080000 01081000 CBAL: 01082000 PROCEDURE; 01083000 DCL 01084000 1 BALCOM STATIC, 01085000 2 ASTR CHAR(3) INIT('* '), /*RAF-45*/ 01086000 2 COMFLD CHAR(69), /*RAF-45*/ 01087000 2 COMID CHAR(8); 01088000 01089000 CALL LABPUSH; 01090000 CALL LABFLUSH; 01091000 INAL = 0; 01092000 DO WHILE(#TRUE) ; 01093000 COL = 80; 01094000 CHAR = ' '; 01095000 CALL RWORD; 01096000 IF WORD = 'ALP' & CHAR = ';' THEN 01097000 DO ; 01098000 INAL = 1 ; 01099000 IF IN_MACRO THEN ASTR='.*'; ELSE ASTR='*'; /*RAF-45*/ 01099500 COMFLD = SUBSTR(CARDIN,1,69) ; /*RAF-45*/ 01100000 COMID = CIN_ID ; 01101000 WRITE FILE(SYSOUT) FROM(BALCOM) ; 01102000 RETURN ; 01103000 END ; 01104000 WRITE FILE(SYSOUT) FROM (CARDIN); 01105000 END; 01106000 END CBAL ; 01107000 1 01107010 /* COMMENT; */ /*RAF-10*/ 01107020 /* <TEXT OF COMMENT> */ /*RAF-10*/ 01107030 /* ALP; */ /*RAF-10*/ 01107040 /*RAF-10*/ 01107050 CCOMMENT: PROCEDURE; /*RAF-10*/ 01107060 /*RAF-10*/ 01107070 DCL /*RAF-10*/ 01107080 1 BALCOM STATIC, /*RAF-10*/ 01107090 2 ASTR CHAR(2) INIT('* '), /*RAF-10*/ 01107100 2 COMFLD CHAR(70), /*RAF-10*/ 01107110 2 COMID CHAR(8); /*RAF-10*/ 01107120 /*RAF-10*/ 01107130 CALL LABPUSH; CALL LABFLUSH; /*RAF-10*/ 01107140 INAL = 0; /*RAF-10*/ 01107150 DO WHILE(#TRUE); /*RAF-10*/ 01107160 COL = 80; CHAR = ' '; /*RAF-10*/ 01107170 CALL RWORD; /*RAF-10*/ 01107180 /*RAF-10*/ 01107190 COMFLD = SUBSTR(CARDIN,1,70); /*RAF-10*/ 01107200 COMID = CIN_ID; /*RAF-10*/ 01107210 WRITE FILE(SYSOUT) FROM(BALCOM); /*RAF-10*/ 01107220 /*RAF-10*/ 01107230 IF WORD='ALP' & CHAR=';' THEN DO; /*RAF-10*/ 01107240 INAL = 1; /*RAF-10*/ 01107250 RETURN; /*RAF-10*/ 01107260 END; /*RAF-10*/ 01107270 END; /*RAF-10*/ 01107280 /*RAF-10*/ 01107290 END CCOMMENT; /*RAF-10*/ 01107300 1 /*RAF-36*/ 01107310 /* DATA <STATEMENT> */ /*RAF-36*/ 01107320 /*RAF-36*/ 01107330 CDATA: PROCEDURE RECURSIVE; /*RAF-36*/ 01107340 DCL AROUND CHAR(8) VARYING; /*RAF-36*/ 01107350 /*RAF-36*/ 01107360 AROUND = GENSYM; /*RAF-36*/ 01107370 GEN('B',AROUND); /*RAF-36*/ 01107380 CALL STMNT; /*RAF-36*/ 01107390 CALL WLABEL(AROUND); /*RAF-36*/ 01107400 END CDATA; /*RAF-36*/ 01107410 1 01108000 /* SELECT; 01109000 <SELECT LIST> 01110000 ENDSEL */ 01111000 01112000 CSELECT: 01113000 PROCEDURE RECURSIVE; 01114000 DECLARE 01115000 (CASEBODY,NEXTCASE,CLABELB,CLABELE) CHAR(8) VARYING, 01116000 EXIT CHAR(8) VARYING, /*RAF-8*/ 01116500 (CHKFIRST,SELEND) BIT(1); 01117000 01118000 CALL SWLABEL(CLABELB); 01119000 DOLEV = DOLEV+1; 01120000 DOID(DOLEV) = CLABELB; 01121000 DOLABEL(DOLEV) = CURLAB; 01122000 NESTLEV = NESTLEV+1; 01123000 NESTID(NESTLEV) = CIN_ID; 01124000 01125000 CHKFIRST = RCHECK('FIRST'); 01126000 IF CHKFIRST THEN 01127000 CLABELE = GENSYM; 01128000 ELSE 01129000 CLABELE = ''; 01130000 EXID(DOLEV) = ''; /*RAF-8*/ 01131000 IF ^RCHAR(';') THEN 01132000 CALL ERROR('CSELECT: MISSING SEMICOLON INSERTED.'); 01133000 01134000 NEXTCASE = ''; /*RAF-4*/ 01134900 SELEND = RCHECK('ENDSEL'); 01135000 DO WHILE(^SELEND); 01136000 CASEBODY = ''; 01137000 NEXTCASE = GENSYM; 01138000 CALL PREDICATE(CASEBODY,NEXTCASE,@OUTER_PREDICATE,#DUMMY, 01139000 @USE_TRUTH,#DUMMY,@B); 01140000 IF ^RCHAR(':') THEN 01141000 CALL ERROR('CSELECT: MISSING COLON INSERTED.'); 01142000 CALL STMNT; 01143000 IF ^RCHAR(';') THEN 01144000 CALL ERROR('CSELECT: MISSING SEMICOLON INSERTED.'); 01145000 SELEND = RCHECK('ENDSEL'); 01146000 IF CHKFIRST & ^SELEND THEN 01147000 GEN('B',CLABELE); 01148000 IF ^SELEND THEN 01149000 CALL WLABEL(NEXTCASE); 01150000 END; /*RAF-4*/ 01151000 1 01152000 NESTLEV = NESTLEV-1; /*RAF-8*/ 01152500 IF RCHECK('ELSE') THEN 01153000 DO; 01154000 IF ^CHKFIRST THEN 01155000 CALL ERROR('CSELECT: "ELSE" ILLEGAL WITHOUT "FIRST"'|| 01156000 ' OPTION ON "SELECT" STATEMENT'); 01157000 IF NEXTCASE^='' THEN DO; /*RAF-4*/ 01157500 IF CLABELE='' THEN /*RAF-8*/ /*RAF-4*/ 01158000 CLABELE = GENSYM; /*RAF-8*/ /*RAF-4*/ 01159000 GEN('B',CLABELE); /*RAF-8*/ /*RAF-4*/ 01160000 CALL WLABEL(NEXTCASE); /*RAF-4*/ 01161000 END; /*RAF-4*/ 01161500 CALL STMNT; 01162000 END; 01163000 ELSE 01164000 CALL CWLABEL(NEXTCASE); 01165000 01166000 EXIT = EXID(DOLEV); /*RAF-8*/ 01166100 DOLEV = DOLEV-1; /*RAF-8*/ 01166200 CALL CWLABEL(CLABELE); /*RAF-8*/ 01166300 IF RCHECK('THEN') THEN CALL STMNT; /*RAF-8*/ 01166400 CALL CWLABEL(EXIT); /*RAF-8*/ 01167000 /* DOLEV = DOLEV-1; */ /*RAF-8*/ 01168000 /* NESTLEV = NESTLEV-1; */ /*RAF-8*/ 01169000 IF NESTLEV=0 THEN PREDLABLEV=0; /*RAF-6*/ 01169500 RETURN; 01170000 END CSELECT; 01171000 1 01172000 ALCSTMT: PROCEDURE; 01173000 DCL 01174000 ( BLANKS72 CHAR(72) INIT(' '), 01175000 L FIXED BIN, 01176000 TLABEL CHAR(8) ) STATIC; 01177000 DCL 01178000 SPECOPS(39) CHAR(8) VAR STATIC INIT( 01179000 'DC','DS','CSECT','DSECT','COM', 01180000 'TITLE','LTORG','CNOP', 01181000 'DROP','USING','ENTRY', 01182000 'SUBTITLE','PRINT','EJECT','SPACE', 01183000 'ICTL','ISEQ','PUNCH','REPRO', 01184000 'ORG','COPY','END', 01185000 'MACRO','MEND','MNOTE','AIF','ANOP','AGO','ACTR','MEXIT', 01186000 'GBLA','GBLB','GBLC','LCLA','LCLB','LCLC','SETA','SETB','SETC' 01187000 ); 01188000 01189000 IF C_LABEL=' ' & LABLEV>0 THEN 01190000 DO; 01191000 C_LABEL = LABSTK(LABLEV); 01192000 LABLEV = LABLEV-1; 01193000 END; 01194000 IF C_LABEL^=' ' THEN 01195000 DO; 01196000 DO L=39 TO 1 BY -1 WHILE(WORD^=SPECOPS(L)); 01197000 END; 01198000 IF (L>0 & SUBSTR(C_LABEL,1,1)='@') | 01199000 (L>8 & SUBSTR(C_LABEL,1,1)^='&') THEN 01200000 CALL LABPUSH; 01201000 END; 01202000 TLABEL = C_LABEL; 01203000 CALL ROPANDS(#FALSE); /*RAF-9*/ 01204000 IF WORD ^= 'CC' THEN 01205000 DO ; 01206000 C_OPERATION = WORD ; 01207000 IF IN_MACRO THEN 01208000 /* IF C_OPERATION = 'MEND' THEN */ /*RAF-8*/ 01209000 /* IN_MACRO = #FALSE; */ /*RAF-8*/ 01210000 /* ELSE */ /*RAF-8*/ 01211000 IF C_OPERATION = 'SPACE' THEN 01212000 DO; 01213000 C_DATA = '.*'; 01214000 OPANDS = ''; 01215000 END; 01216000 01217000 IF WORD='SUBTITLE' THEN 01218000 DO; 01219000 C_OPERATION = 'TITLE' ; 01220000 SUBTITL = #TRUE; 01221000 SUBTITLE = SUBSTR(BLANKS72,1,(73-LENGTH(OPANDS)-2)/2) 01222000 ||SUBSTR(OPANDS,2,LENGTH(OPANDS)-2); 01223000 END; 01224000 01225000 GEN_OPERANDS(OPANDS); 01226000 END ; 01227000 1 01228000 IF WORD = 'SPACE' THEN 01229000 PUT SKIP(2) FILE(SYSPRINT); 01230000 ELSE 01231000 IF WORD='TITLE' | WORD='EJECT' THEN 01232000 DO; 01233000 IF WORD='TITLE' THEN 01234000 DO; 01235000 DECKNAME = TLABEL; 01236000 TITLE = SUBSTR(BLANKS72,1,(73-LENGTH(OPANDS)-2)/2) 01237000 ||SUBSTR(OPANDS,2,LENGTH(OPANDS)-2); 01238000 END; 01239000 SIGNAL ENDPAGE(SYSPRINT); 01240000 END; 01241000 INAL = 1 ; 01242000 RETURN; 01243000 END ALCSTMT; 01244000 1 01245000 /* GENERATE CODE FOR PREDICATES */ 01246000 PREDICATE: 01247000 PROCEDURE(THRULABEL,BRLABEL,OUTER,PREDFOUND,GLOBALNEG,HANGNOT,BTYPE) 01248000 RECURSIVE; 01249000 01250000 /* THRULABEL = FALL-THROUGH LABEL 01251000 BRLABEL = BRANCH LABEL 01252000 OUTER=#TRUE => PREDICATE IS AN OUTER ONE 01253000 PREDFOUND => SET IF WE FIND WE ARE IN A PREDICATE, ELSE FALSE 01254000 GLOBALNEG=#TRUE => GLOBAL NEGATION OF PREDICATE 01255000 BTYPE=#TRUE => BR FORM */ 01256000 01257000 DCL (THRULABEL,BRLABEL) CHAR(*) VARYING, 01258000 (OUTER,PREDFOUND,GLOBALNEG,HANGNOT,BTYPE) BIT(1); 01259000 DCL (BTRUTH,PREDNEST,ANDFLG,ORFLG) BIT(1), 01260000 (THRULAB,BRLAB) CHAR(8) VARYING, 01261000 PREDID CHAR(8); 01262000 01263000 PREDFOUND = #FALSE; 01264000 THRULAB,BRLAB = ''; 01265000 01266000 BTRUTH = ^GLOBALNEG; 01267000 DO WHILE(RCHAR('^')); 01268000 BTRUTH = ^BTRUTH; 01269000 PREDFOUND = #TRUE; 01270000 END; 01271000 01272000 IF ^RCHAR('<') THEN 01273000 CALL STMNT; 01274000 ELSE 01275000 DO; 01276000 NESTLEV = NESTLEV+1; NESTID(NESTLEV) = CIN_ID; /*RAF-28*/ 01276500 PREDID = CIN_ID; 01277000 CALL PREDICATE(THRULAB,BRLAB,@INNER_PREDICATE,PREDNEST, 01278000 ^BTRUTH,HANGNOT,BTYPE); 01279000 IF ^PREDNEST THEN 01280000 DO; 01281000 IF RCHAR(';') THEN 01282000 DO; 01283000 NESTLEV = NESTLEV-1; /*RAF-28*/ 01283500 CALL GROUP(#FALSE,PREDID); 01284000 GOTO PREDTST; 01285000 END; 01286000 ELSE 01287000 IF ^RCHAR('>') THEN 01288000 DO; 01289000 CALL ERROR('CPRED: MISSING SEMICOLON INSERTED.');01290000 NESTLEV = NESTLEV-1; /*RAF-28*/ 01290500 CALL GROUP(#FALSE,PREDID); 01291000 GOTO PREDTST; 01292000 END; 01293000 ELSE DO; /*RAF-28*/ 01293100 NESTLEV = NESTLEV-1; /*RAF-28*/ 01293200 IF NESTLEV=0 THEN PREDLABLEV=0; /*RAF-28*/ 01293300 END; /*RAF-28*/ 01293400 END; 01294000 ELSE 01295000 DO; 01296000 PREDFOUND = #TRUE; 01297000 IF ^RCHAR('>') THEN 01298000 CALL ERROR('CPRED: MISSING ">" INSERTED.'); 01299000 ELSE DO; /*RAF-28*/ 01299100 NESTLEV = NESTLEV-1; /*RAF-28*/ 01299200 IF NESTLEV=0 THEN PREDLABLEV=0; /*RAF-28*/ 01299300 END; /*RAF-28*/ 01299400 END; 01300000 END; 01301000 1 01302000 PREDTST: 01303000 ANDFLG,ORFLG = #FALSE; 01304000 IF RCHAR('&') THEN 01305000 IF GLOBALNEG THEN ORFLG = #TRUE; 01306000 ELSE ANDFLG = #TRUE; 01307000 ELSE 01308000 IF RCHAR('|') THEN 01309000 IF GLOBALNEG THEN ANDFLG = #TRUE; 01310000 ELSE ORFLG = #TRUE; 01311000 IF ANDFLG THEN 01312000 DO; 01313000 PREDFOUND = #TRUE; 01314000 CALL GB(^XOR(BTRUTH,HANGNOT),BRLABEL,BTYPE); 01315000 HANGNOT = #FALSE; 01316000 CALL EQU(BRLAB,BRLABEL); 01317000 CALL CWLABEL(THRULAB); 01318000 CALL PREDICATE(THRULABEL,BRLABEL,OUTER,#DUMMY,GLOBALNEG,HANGNOT, 01319000 BTYPE); 01320000 END; 01321000 ELSE 01322000 IF ORFLG THEN 01323000 DO; 01324000 PREDFOUND = #TRUE; 01325000 CALL GB(XOR(BTRUTH,HANGNOT),THRULABEL,BTYPE); 01326000 HANGNOT = #FALSE; 01327000 CALL EQU(THRULAB,THRULABEL); 01328000 CALL CWLABEL(BRLAB); 01329000 CALL PREDICATE(THRULABEL,BRLABEL,OUTER,#DUMMY,GLOBALNEG, 01330000 HANGNOT,BTYPE); 01331000 END; 01332000 ELSE 01333000 DO; 01334000 IF THRULABEL='' & THRULAB^='' THEN 01335000 DO; 01336000 THRULABEL = THRULAB; 01337000 THRULAB = ''; 01338000 END; 01339000 IF BRLABEL='' & BRLAB^='' THEN 01340000 DO; 01341000 BRLABEL = BRLAB; 01342000 BRLAB = ''; 01343000 END; 01344000 CALL EQU(THRULAB,THRULABEL); 01345000 CALL EQU(BRLAB,BRLABEL); 01346000 IF OUTER THEN 01347000 DO; 01348000 CALL GB(^XOR(BTRUTH,HANGNOT),BRLABEL,BTYPE); 01349000 HANGNOT = #FALSE; 01350000 CALL CWLABEL(THRULABEL); 01351000 END; 01352000 ELSE 01353000 HANGNOT = HANGNOT | XOR(BTRUTH,^GLOBALNEG); 01354000 END; 01355000 01356000 RETURN; 01357000 1 01358000 EQU: PROCEDURE(L1,L2); 01359000 DCL (L1,L2) CHAR(*) VARYING; 01360000 DCL ( (I,PREVOP) FIXED BIN, 01361000 REG_DISP BIT(1) ) STATIC; 01362000 01363000 PREVOP = 0; 01364000 IF L2^='' THEN IF SUBSTR(L2,LENGTH(L2),1)=')' THEN /*RAF-3*/ 01365000 DO I=1 TO LENGTH(L2); 01366000 IF SUBSTR(L2,I,1)='(' & PREVOP=0 THEN 01367000 DO; 01368000 REG_DISP = #TRUE; 01369000 GOTO PREDLABCHK; 01370000 END; 01371000 PREVOP = INDEX('+-*/',SUBSTR(L2,I,1)); 01372000 END; 01373000 REG_DISP = #FALSE; 01374000 01375000 PREDLABCHK: 01376000 DO I=PREDLABLEV TO 1 BY -1 WHILE(L1^=PREDLABSTK(I,2)); 01377000 END; 01378000 IF I>0 THEN 01379000 REG_DISP = PREDBTYPE(I)='R'; 01380000 IF I=0 | ^REG_DISP THEN 01381000 DO; 01382000 IF L1^='' & L2^='' THEN 01383000 CALL EQVADD((L1),(L2)); 01384000 END; 01385000 ELSE 01386000 DO; 01387000 CALL WLABEL(L1); 01388000 GEN('DS','0H'); 01389000 GEN('ORG',PREDLABSTK(I,1)||'+2'); 01390000 IF PREDBTYPE(I)='R' THEN 01391000 GEN('DC','S(0('||L2||'))'); 01392000 ELSE 01393000 GEN('DC','S('||L2||')'); 01394000 GEN('ORG',L1); 01395000 END; 01396000 01397000 IF I>0 THEN 01398000 DO; 01399000 DO I=I+1 TO PREDLABLEV; 01400000 PREDLABSTK(I-1,1) = PREDLABSTK(I,1); 01401000 PREDLABSTK(I-1,2) = PREDLABSTK(I,2); 01402000 END; 01403000 PREDLABLEV = PREDLABLEV-1; 01404000 END; 01405000 RETURN; 01406000 END EQU; 01407000 01408000 XOR: PROCEDURE(B1,B2) RETURNS(BIT(1)); 01409000 DCL (B1,B2) BIT(1); 01410000 RETURN((B1 & ^B2) | (^B1 & B2)); 01411000 END XOR; 01412000 01413000 /* END PREDICATE; */ /*RAF-6*/ 01414000 1 01415000 GB: 01416000 PROCEDURE (B,LABLST,BRT); 01417000 /* GENERATE CONDITIONAL BRANCH (ON TRUTH IF B) TO LABLST */ 01418000 DCL 01419000 (B,BRT) BIT(1), 01420000 LABLST CHAR(*) VARYING; 01421000 DCL 01422000 LABLADDR CHAR(8) VARYING STATIC, /*RAF-41*/ 01423000 (I,J) FIXED BIN STATIC, /*RAF-41*/ 01424000 CCCODE CHAR(8) STATIC, /*RAF-41*/ 01425000 CCODE FIXED BIN STATIC; /*RAF-41*/ 01426000 /*RAF-41*/ 01426100 CCODE = 0; /*RAF-41*/ 01426200 01427000 IF LABLST='' THEN 01428000 DO; 01429000 CALL SWLABEL(LABLADDR); 01430000 PREDLABLEV = PREDLABLEV+1; 01431000 PREDLABSTK(PREDLABLEV,1) = LABLADDR; 01432000 LABLST = GENSYM; 01433000 PREDLABSTK(PREDLABLEV,2) = LABLST; 01434000 IF BRT THEN 01435000 PREDBTYPE(PREDLABLEV) = 'R'; 01436000 ELSE 01437000 PREDBTYPE(PREDLABLEV) = ''; 01438000 END; 01439000 01440000 IF WORD = 'CC' THEN 01441000 DO; 01442000 IF LENGTH(OPANDS)>8 THEN 01443000 CALL ERROR('GB: CONDITION CODE STRING TOO LONG.'); 01444000 CCCODE = OPANDS; 01445000 END; 01446000 ELSE 01447000 DO; 01448000 DO I = 1 TO 17 WHILE(PREDICATES(I,1) ^= WORD); 01449000 END; 01450000 CCCODE = PREDICATES(I,2); 01451000 END; 01452000 1 01453000 /* CCCODE IS NOW A SET OF MNEMONIC COND CODE CHARACTERS */ 01454000 DO I = 1 TO 8; /* FOR EACH CHAR .. */ 01455000 J = INDEX(CCTAB.LET, SUBSTR(CCCODE, I, 1)); 01456000 IF J = 0 THEN 01457000 CALL 01458000 ERROR('UNDEF COND CODE CHAR: ' || SUBSTR(CCCODE,I,1) ); 01459000 ELSE 01460000 CCODE = CCODE+CCTAB.IVAL(J); 01461000 END; 01462000 IF INDEX(CCCODE, 'N') | INDEX(CCCODE,'^') THEN 01463000 CCODE = 15-CCODE; 01464000 IF ^B THEN 01465000 CCODE = 15-CCODE; 01466000 SUBSTR(CARDOUT,10,10) = OPTAB(CCODE+1); 01467000 IF BRT & SUBSTR(LABLST,1,1)^='@' THEN 01468000 IF SUBSTR(C_OPERATION,3,1)=' ' THEN 01469000 SUBSTR(C_OPERATION,3,1)='R'; 01470000 ELSE 01471000 SUBSTR(C_OPERATION,4,1)='R'; 01472000 C_OPERANDS = LABLST; 01473000 CALL WFLUSH; 01474000 RETURN; 01475000 01476000 END GB; 01477000 END PREDICATE; /*RAF-6*/ 01477500 1 01478000 /* WRITE LABEL */ 01479000 WLABEL: 01480000 PROCEDURE (ALABL); 01481000 DCL 01482000 ALABL CHAR(*) VARYING; 01483000 DCL 01484000 I FIXED BIN STATIC; 01485000 01486000 GOTO WLABELX; 01487000 0 01488000 SWLABEL: 01489000 ENTRY(ALABL); 01490000 01491000 IF C_LABEL ^= ' ' THEN 01492000 ALABL = C_LABEL; 01493000 ELSE 01494000 IF LABLEV>0 THEN 01495000 ALABL = LABSTK(LABLEV); 01496000 ELSE 01497000 ALABL = ''; 01498000 IF ALABL^='' THEN IF SUBSTR(ALABL,1,1)^='.' THEN /*RAF-3*/ 01499000 RETURN; 01500000 /* ELSE */ /*RAF-3*/ 01501000 DO; 01502000 ALABL = GENSYM; 01503000 GOTO WLABELX; 01504000 END; 01505000 0 01506000 CWLABEL: 01507000 ENTRY(ALABL); 01508000 01509000 IF ALABL='' THEN RETURN; 01510000 0 01511000 WLABELX: IF C_LABEL ^= ' ' THEN 01512000 DO; /* LABEL ALREADY IN BUFFER */ 01513000 LABLEV = LABLEV+1; 01514000 LABSTK(LABLEV) = C_LABEL; 01515000 END; 01516000 DO I = 1 TO EQVLEV; 01517000 IF EQVSTK(I,2) = ALABL THEN 01518000 DO; 01519000 LABLEV = LABLEV+1; 01520000 LABSTK(LABLEV) = EQVSTK(I,1); 01521000 EQVSTK(I,*) = ''; 01522000 END; 01523000 END; 01524000 C_LABEL = ALABL ; 01525000 IF COL_1^='&' & COL_1^='.' THEN /*RAF-12*/ 01526000 DO; 01527000 SYMLEV = SYMLEV+1; 01528000 SYMSTK(SYMLEV) = ALABL; 01529000 END; 01530000 CALL PERPUSH; 01531000 RETURN; 01532000 END WLABEL ; 01533000 1 01534000 /* FLUSH OUTPUT LINE */ 01535000 WFLUSH: 01536000 PROCEDURE ; 01537000 DCL ( (I,J) FIXED BIN, 01538000 (FLUSH,LAST_WAS_BRANCH,NOWRITE) BIT(1), 01539000 TLABEL CHAR(8) VARYING, 01540000 CH CHAR(1) ) STATIC; 01541000 01542000 IF C_OPERATION='ANOP' & C_LABEL='' THEN RETURN; /*RAF-29*/ 01542100 /*RAF-29*/ 01542200 LAST_WAS_BRANCH = BRANCH_LAST; 01543000 BRANCH_LAST,NOWRITE = #FALSE; 01544000 IF REQFLUSH(C_OPERATION) THEN 01545000 DO; 01546000 FLUSH = #TRUE; 01547000 IF C_OPERATION = 'B' THEN 01548000 DO; 01549000 DO I = 1 TO 52 /*RAF-41*/ 01550000 WHILE(ALPHANUM(SUBSTR(C_OPERANDS,I,1))); /*RAF-41*/ 01550100 END; 01551000 CH = SUBSTR(C_OPERANDS,I,1); 01552000 IF (I>1 & I<=9) & 01553000 (CH = ' ' | CH = ';' | CH = '%' | CH = '>') THEN 01554000 DO; /* BRANCH TO SIMPLE LABEL */ 01555000 FLUSH = #FALSE; 01556000 BRANCH_LAST = #TRUE; 01557000 IF C_LABEL = ' ' & LABLEV>0 THEN DO; /*RAF-2*/ 01557100 C_LABEL = LABSTK(LABLEV); /*RAF-2*/ 01557200 LABLEV = LABLEV-1; /*RAF-2*/ 01557300 END; /*RAF-2*/ 01557400 IF C_LABEL ^= ' ' & (^IN_MACRO /*RAF-43*/ 01558000 | SUBSTR(C_OPERANDS,1,1)='@') /*RAF-43*/ 01558500 THEN DO; /*RAF-43*/ 01559000 LABLEV = LABLEV+1; 01560000 LABSTK(LABLEV) = C_LABEL; 01561000 TLABEL = SUBSTR(C_OPERANDS,1,I-1); 01562000 DO I=LABLEV TO 1 BY -1 01563000 WHILE(LABSTK(I)^=TLABEL); 01564000 END; 01565000 IF I>0 THEN 01566000 DO; 01567000 LABLEV = LABLEV-1; 01568000 CALL LABFLUSH; 01569000 END; 01570000 ELSE 01571000 DO; 01572000 C_LABEL = ' '; 01573000 DO J = 1 TO LABLEV; 01574000 CALL EQVADD((LABSTK(J)),(TLABEL)); 01575000 END; 01576000 LABLEV = 0; 01577000 END; 01578000 END; 01579000 NOWRITE = LAST_WAS_BRANCH & ^LABEL_WRITTEN ; 01580000 END; 01581000 END; 01582000 IF FLUSH THEN 01583000 CALL LABFLUSH; 01584000 END; 01585000 1 01586000 IF ^NOWRITE THEN 01587000 WRITE FILE(SYSOUT) FROM(CARDOUT) ; 01588000 LABEL_WRITTEN = #FALSE; 01589000 C_DATA = ' '; 01590000 IF INAL = 2 THEN 01591000 INAL = 1 ; 01592000 RETURN; 01593000 01594000 /* PROCEDURE TO SIGNAL WHEN STACK FLUSH IS REQUIRED */ 01595000 REQFLUSH: PROC(OPCODE) RETURNS(BIT(1)); 01596000 DCL OPCODE CHAR(8); 01597000 DCL I FIXED BIN STATIC, 01598000 NOFLUSH(26) CHAR(8) STATIC INIT( 01599000 ' ','DROP','USING','EQU', 01600000 'TITLE','SUBTITLE','PRINT','EJECT','SPACE', 01601000 'ICTL','ISEQ','PUNCH', 01602000 'MNOTE','AIF','ANOP','AGO','ACTR', 01603000 'GBLA','GBLB','GBLC','LCLA','LCLB','LCLC','SETA','SETB','SETC' 01604000 ); 01605000 01606000 DO I=1 TO 26; 01607000 IF OPCODE=NOFLUSH(I) THEN RETURN(#FALSE); 01608000 END; 01609000 RETURN(#TRUE); 01610000 END REQFLUSH; 01611000 END WFLUSH ; 01612000 1 01613000 /* FLUSH LABEL EQUIVALENCING STACK */ 01614000 EQVFLUSH: 01615000 PROCEDURE(LEVZ,ELEVL); 01616000 DCL 01617000 LEVZ BIT(1), 01618000 ELEVL FIXED BIN, 01619000 I FIXED BIN STATIC; /*RAF-41*/ 01619500 DCL 01620000 EQVBUF CHAR(80) STATIC INIT(' EQU') UNALIGNED, /*RAF-46*/ 01621000 E_LABEL CHAR(8) POS(1) DEF EQVBUF UNALIGNED, /*RAF-46*/ 01622000 E_OPERAND CHAR(61) POS(20) DEF EQVBUF UNALIGNED; /*RAF-46*/ 01623000 IF EQVLEV>0 THEN 01624000 DO; 01625000 DO I = ELEVL TO EQVLEV; 01626000 E_LABEL = EQVSTK(I,1); 01627000 IF E_LABEL ^= ' ' THEN 01628000 DO; 01629000 E_OPERAND = EQVSTK(I,2); 01630000 /* IF ((SUBSTR(E_OPERAND,1,1)='@') | */ /*RAF-12*/ 01631000 /* (SUBSTR(E_OPERAND,1,1)^='@' & */ /*RAF-12*/ 01632000 IF LEVZ | SYMDEF(EQVSTK(I,2)) THEN /*RAF-12*/ 01633000 DO; 01634000 EQVSTK(I,*) = ''; 01635000 WRITE FILE(SYSOUT) FROM(EQVBUF); 01636000 END; 01637000 END; 01638000 END; 01639000 IF LEVZ THEN 01640000 EQVLEV = 0; 01641000 END; 01642000 RETURN; 01643000 01644000 SYMDEF: PROCEDURE(SYMBOL) RETURNS(BIT(1)); 01645000 DCL SYMBOL CHAR(*) VARYING; 01646000 DCL I FIXED BIN STATIC; 01647000 01648000 DO I=SYMLEV TO 1 BY -1; 01649000 IF SYMSTK(I)=SYMBOL THEN RETURN(#TRUE); 01650000 END; 01651000 RETURN(#FALSE); 01652000 END SYMDEF; 01653000 01654000 END EQVFLUSH; 01655000 1 01656000 LABFLUSH: PROCEDURE; 01657000 DCL 01658000 I FIXED BIN STATIC, 01659000 FLUSHBUF CHAR(80) STATIC UNALIGNED /*RAF-46*/ 01660000 INIT(' DS 0H'), /*RAF-46*/ 01660100 F_LABEL CHAR(8) POS(1) DEF FLUSHBUF UNALIGNED, /*RAF-46*/ 01661000 F_ID CHAR(8) POS(73) DEF FLUSHBUF UNALIGNED; /*RAF-46*/ 01662000 01663000 F_ID = CIN_ID; 01664000 IF LABLEV>0 THEN 01665000 DO; 01666000 LABEL_WRITTEN = #TRUE; 01667000 DO I = 1 TO LABLEV; 01668000 F_LABEL = LABSTK(I); 01669000 WRITE FILE(SYSOUT) FROM(FLUSHBUF); 01670000 END; 01671000 LABLEV = 0; 01672000 END; 01673000 RETURN; 01674000 END LABFLUSH; 01675000 1 01676000 /* PUSH NON-SEQUENCE LABELS */ 01677000 LABPUSH: PROCEDURE; 01678000 DCL 01679000 (I,J) FIXED BIN STATIC, /*RAF-41*/ 01680000 SEQBUF CHAR(80) STATIC INIT(' ANOP') UNAL, /*RAF-46*/ 01681000 S_LABEL CHAR(8) POS(1) DEF SEQBUF UNALIGNED, /*RAF-46*/ 01682000 S_ID CHAR(8) POS(73) DEF SEQBUF UNALIGNED, /*RAF-46*/ 01683000 S_COL1 CHAR(1) POS(1) DEF SEQBUF UNALIGNED; /*RAF-46*/ 01684000 01685000 IF C_LABEL^=' ' & SUBSTR(C_LABEL,1,1)^='.' THEN 01686000 DO; 01687000 LABLEV = LABLEV+1; 01688000 LABSTK(LABLEV) = C_LABEL; 01689000 C_LABEL = ''; 01690000 END; 01691000 01692000 PERPUSH: ENTRY; 01693000 IF LABLEV>0 THEN 01694000 DO; 01695000 S_ID = CIN_ID; 01696000 J = 0; 01697000 DO I=1 TO LABLEV; 01698000 S_LABEL = LABSTK(I); 01699000 IF S_COL1='.' THEN 01700000 WRITE FILE(SYSOUT) FROM(SEQBUF); 01701000 ELSE 01702000 DO; 01703000 J = J+1; 01704000 LABSTK(J) = LABSTK(I); 01705000 END; 01706000 END; 01707000 IF LABLEV^=J THEN 01708000 DO; 01709000 LABLEV = J; 01710000 LABEL_WRITTEN = #TRUE; 01711000 END; 01712000 END; 01713000 RETURN; 01714000 END LABPUSH; 01715000 0 01716000 /* GENERATE A LABEL SYMBOL */ 01717000 GENSYM: PROCEDURE RETURNS(CHAR(8) VARYING); 01718000 GENNUM = GENNUM+1; 01719000 IF IN_MACRO THEN 01720000 RETURN('@&@.'||SUBSTR(GENNUM,6)); 01721000 ELSE 01722000 RETURN('@'||SUBSTR(GENNUM,5)); 01723000 01724000 /* GENERATE A SEQUENCE SYMBOL */ 01725000 GENSEQSYM: ENTRY RETURNS(CHAR(8) VARYING); 01726000 GENNUM = GENNUM+1; 01727000 RETURN('.@'||SUBSTR(GENNUM,5)); 01728000 01729000 END GENSYM; 01730000 1 01731000 /* PROCEDURE TO ADD A LABEL AND TARGET TO THE EQUIVALENCING STACK */ 01732000 EQVADD: PROCEDURE(EQLABEL,EQTARGET); 01733000 DCL (EQLABEL,EQTARGET) CHAR(*) VARYING; 01734000 DCL I FIXED BIN STATIC, /*RAF-41*/ 01735000 HIT BIT(1) STATIC; /*RAF-41*/ 01736000 01737000 HIT = #FALSE; /*RAF-41*/ 01737500 DO I=1 TO EQVLEV; 01738000 IF EQVSTK(I,1)='' THEN 01739000 DO; 01740000 IF ^HIT THEN 01741000 DO; 01742000 HIT = #TRUE; 01743000 EQVSTK(I,1) = EQLABEL; 01744000 EQVSTK(I,2) = EQTARGET; 01745000 END; 01746000 END; 01747000 ELSE 01748000 DO; 01749000 IF EQVSTK(I,2)=EQLABEL THEN 01750000 EQVSTK(I,2) = EQTARGET; 01751000 IF EQTARGET=EQVSTK(I,1) THEN 01752000 EQTARGET = EQVSTK(I,2); 01753000 END; 01754000 END; 01755000 IF ^HIT THEN 01756000 DO; 01757000 EQVLEV = EQVLEV+1; 01758000 EQVSTK(I,1) = EQLABEL; 01759000 EQVSTK(I,2) = EQTARGET; 01760000 END; 01761000 RETURN; 01762000 01763000 END EQVADD; 01764000 1 01765000 /* INPUT: */ /* ALP INPUT ROUTINES */ /*RAF-41*/ 01766000 /* PROCEDURE ; */ /*RAF-41*/ 01767000 01768000 /* 01769000 RWORD READ WORD INTO 'WORD' 01770000 SKIP,INC 01771000 ALPHANUM 01772000 RLABEL READ LABEL INTO 'WORD' 01773000 SKIP,INC 01774000 ALPHANUM 01775000 ROPANDS READ OPERANDS INTO 'OPANDS' 01776000 SKIP,INC 01777000 RCHAR('C') READ CHAR IF IT IS 'C' 01778000 SKIP,INC 01779000 RCHECK(CHKWORD) READ 'CHKWORD' IF PRESENT 01780000 SKIP,INC 01781000 ALPHANUM 01782000 */ 01783000 01784000 /*DECLARE */ /*RAF-41*/ 01785000 /* STARTCOL FIXED BIN STATIC, */ /*RAF-41*/ 01786000 /* I FIXED BIN STATIC; */ /*RAF-41*/ 01787000 1 01788000 RWORD: PROCEDURE; /*RAF-41*/ 01789000 /* READ NEXT TOKEN INTO 'WORD'. A TOKEN IS A SINGLE 01790000 SPECIAL CHARACTER OR 1-8 ALPHANUMERICS. 'WORDAL' 01791000 IS SET TO #TRUE IFF 'WORD' IS ALPHANUMERIC. */ 01792000 DCL (STARTCOL,I) FIXED BIN STATIC; /*RAF-41*/ 01792500 CALL SKIP; 01793000 IF COL<71 & SUBSTR(CARDIN,COL,2)='&&' 01794000 & ALPHANUM(SUBSTR(CARDIN,COL+2,1)) THEN 01795000 DO; 01796000 COL = COL+1 ; 01797000 CHAR = 'A' ; 01798000 END; 01799000 IF ^ALPHANUM(CHAR) THEN 01800000 DO ; /* WORD IS NOT ALPHANUMERIC */ 01801000 WORD = CHAR ; 01802000 IF CHAR ^= ';' THEN 01803000 CALLINC; 01804000 WORDAL = #FALSE ; 01805000 END; 01806000 ELSE 01807000 DO ; 01808000 WORDAL = #TRUE ; /* WORD IS ALPHANUMERIC */ 01809000 STARTCOL = COL ; 01810000 DO I = 0 BY 1 WHILE(ALPHANUM(CHAR)) ; 01811000 CALLINC; 01812000 END; 01813000 WORD = SUBSTR(CARDIN,STARTCOL,I) ; 01814000 IF I>8 & INAL^=0 THEN /*RAF-10*/ 01815000 CALL ERROR('RW40: TOO MANY CHARACTERS IN WORD "'|| 01816000 SUBSTR(CARDIN,STARTCOL,I)||'".'); 01817000 END; 01818000 RETURN; 01819000 END RWORD; /*RAF-41*/ 01819500 1 01820000 RLABEL: PROCEDURE; /*RAF-41*/ 01821000 /* SCAN OFF A LABEL : BEGINS WITH 'A'-'Z','@','#','$',01822000 AND '.' OR '&' AS SPECIAL CASES. ENDS WITH BLANK OR 01823000 ANY NON-ALPHANUMERIC OTHER THAN '.' '&' '(' ')' */ 01824000 DCL LABEL CHAR(20) VARYING STATIC; /*RAF-41*/ 01825000 DCL STARTCOL FIXED BIN STATIC; /*RAF-41*/ 01825500 CALL SKIP; 01826000 IF ^ALPHANUM(CHAR) & CHAR^='.' & CHAR^='&' THEN 01827000 DO ; /* WORD IS NOT ALPHANUMERIC */ 01828000 WORDAL = #FALSE ; 01829000 WORD = CHAR ; 01830000 IF CHAR ^= ';' THEN 01831000 CALLINC; 01832000 RETURN ; 01833000 END; 01834000 01835000 WORDAL = #TRUE; 01836000 IF CHAR='.' THEN 01837000 DO; 01838000 LABEL = '.'; 01839000 CALLINC; 01840000 END; 01841000 ELSE 01842000 LABEL = ''; 01843000 STARTCOL = COL; 01844000 DO WHILE(ALPHANUM(CHAR) | CHAR='&' | CHAR='.' /*RAF-26*/ 01845000 | (CHAR='(' 01846000 /*RAF-3*/ /* & (SUBSTR(LABEL,1,1)='&' & SUBSTR(CARDIN,COL+1,1)='&')) */01847000 | (CHAR=')' 01848000 /*RAF-3*/ /* & (SUBSTR(LABEL,1,1)='&') */ ))); 01849000 IF CHAR='&' THEN 01850000 DO; 01851000 CALLINC; 01852000 LABEL = LABEL||SUBSTR(CARDIN,STARTCOL,COL-STARTCOL); 01853000 IF CHAR='&' THEN 01854000 CALLINC; 01855000 ELSE 01856000 CALL ERROR('LB40: "&" INSERTED.'); 01857000 STARTCOL = COL; 01858000 END; 01859000 ELSE 01860000 CALLINC; 01861000 END; 01862000 LABEL = LABEL||SUBSTR(CARDIN,STARTCOL,COL-STARTCOL) ; 01863000 IF LENGTH(LABEL)>8 THEN 01864000 CALL ERROR('LB60: TOO MANY CHARACTERS IN LABEL "'||LABEL||'".');01865000 WORD = LABEL; 01866000 IF CHAR^=' ' & CHAR^=':' & CHAR^=';' & CHAR^='>' THEN 01867000 CALL ERROR('LB50: BLANK INSERTED.'); 01868000 RETURN; 01869000 END RLABEL; /*RAF-41*/ 01869500 1 01870000 ROPANDS: 01871000 PROCEDURE(COMMASW); /*RAF-41*/ /*RAF-9*/ 01872000 /* BUILD OPERANDS OF A NON-ALP INSTRUCTION IN "OPANDS" */ 01873000 DCL COMMASW BIT(1), /*RAF-9*/ 01873100 TERMCHAR CHAR(8) VARYING STATIC; /*RAF-41*/ /*RAF-9*/ 01873200 DCL STARTCOL FIXED BIN STATIC; /*RAF-41*/ 01873250 IF COMMASW THEN TERMCHAR=' %;|&>:,'; /*RAF-9*/ 01873300 ELSE TERMCHAR = ' %;|&>'; /*RAF-9*/ 01873400 OPANDS = ''; 01874000 ROA: CALL SKIP; 01875000 STARTCOL = COL; 01876000 RO_CHARLOOP: 01877000 DO WHILE(#TRUE); 01878000 IF INDEX(TERMCHAR, CHAR) /* TERMINAL CHARS */ THEN /*RAF-9*/ 01879000 DO; 01880000 IF OPANDS = '' THEN 01881000 OPANDS = SUBSTR(CARDIN,STARTCOL,COL-STARTCOL); 01882000 ELSE 01883000 OPANDS = OPANDS||SUBSTR(CARDIN,STARTCOL,COL-STARTCOL);01884000 IF CHAR='&' & COL<72 & SUBSTR(CARDIN,COL+1,1)='&' THEN 01885000 DO; 01886000 STARTCOL,COL = COL+1; 01887000 CALLINC; 01888000 GO TO RO_CHARLOOP; 01889000 END; 01890000 GO TO OPTRUNC; 01891000 END; 01892000 IF CHAR = '_' /* INPUT CONTINUATION */ THEN 01893000 DO; 01894000 IF OPANDS = '' THEN 01895000 OPANDS = SUBSTR(CARDIN,STARTCOL,COL-STARTCOL); 01896000 ELSE 01897000 OPANDS = OPANDS||SUBSTR(CARDIN,STARTCOL,COL-STARTCOL);01898000 CALLINC; 01899000 GO TO ROA; 01900000 END; 01901000 IF CHAR = '''' THEN 01902000 DO; 01903000 IF COL>1 THEN 01904000 DO; 01905000 IF VERIFY(SUBSTR(CARDIN,COL-1,1), /*RAF-14*/ 01906000 'LKNTSI')^=0 THEN /*RAF-14*/ 01906500 GO TO RO_PRIMES; 01907000 END; 01908000 ELSE 01909000 DO; 01910000 IF SUBSTR(OPANDS,LENGTH(OPANDS),1) ^= 'L' THEN 01911000 GO TO RO_PRIMES; 01912000 END; 01913000 END; 01914000 CALLINC ; 01915000 END RO_CHARLOOP ; 01916000 01917000 OPTRUNC: 01918000 RETURN; 01919000 1 01920000 RO_PRIMES: 01921000 CALLINC; 01922000 RO_PRIMELOOP: 01923000 DO WHILE(CHAR ^= ''''); 01924000 IF COL > 72 THEN 01925000 DO ; 01926000 CALL ERROR('RO30: MISSING QUOTE IN "'||CARDIN||'".'); 01927000 RETURN; 01928000 END; 01929000 CALLINC; 01930000 END RO_PRIMELOOP; 01931000 CALLINC ; /* SKIP PRIME */ 01932000 01933000 /* IF NOT LITERAL CONTINUE */ 01934000 IF SUBSTR(CARDIN, COL ,1) ^= '_' THEN 01935000 GO TO RO_CHARLOOP; 01936000 /* CONTINUED LITERAL : */ 01937000 COL = COL - 1 ; 01938000 OPANDS = OPANDS||SUBSTR(CARDIN,STARTCOL,COL-STARTCOL); 01939000 CALLINC; 01940000 CALLINC; 01941000 CALL SKIP; 01942000 STARTCOL = COL + 1 ; 01943000 IF CHAR = '''' THEN 01944000 GO TO RO_PRIMES ; 01945000 CALL ERROR('RO50: IMPROPERLY CONTINUED LITERAL.'); 01946000 RETURN; 01947000 END ROPANDS; /*RAF-41*/ 01947500 1 01948000 /* ENTRY TO SCAN OFF CONDITION CLAUSE FOR CONDITIONAL ASM */ 01949000 CONDSCAN: PROCEDURE(PARSW) RETURNS(CHAR(170) VAR); /*RAF-41*//*RAF-9*/ 01950000 DCL 01951000 PARSW BIT(1), /*RAF-9*/ 01951500 PLEV FIXED BIN STATIC, 01952000 CONDSTR CHAR(170) VAR STATIC; 01953000 DCL 01954000 (CSTATE,INDX) FIXED BIN STATIC, 01955000 STATE(3,4) LABEL /* STATIC */ INIT 01956000 (S11,S12,S13,S14, 01957000 S21,S22,S23,S24, 01958000 S31,S32,S33,S34); 01959000 01960000 IF ^PARSW THEN DO; /*RAF-9*/ 01960100 IF ^RCHAR('(') THEN DO; /*RAF-9*/ 01960200 CALL ERROR('CONDSCAN: MISSING CONDITION CLAUSE');/*RAF-9*/ 01960300 RETURN(''); /*RAF-9*/ 01960400 END; /*RAF-9*/ 01960500 END; /*RAF-9*/ 01960600 /*RAF-9*/ 01960700 PLEV = 1; 01961000 CONDSTR = '('; 01962000 GO TO NXT2; 01963000 NXT1: CALLINC; 01964000 NXT2: IF CHAR = '(' THEN 01965000 PLEV = PLEV+1; 01966000 ELSE 01967000 IF CHAR = ')' THEN 01968000 DO; 01969000 PLEV = PLEV-1; 01970000 IF PLEV = 0 THEN 01971000 DO; 01972000 CONDSTR = CONDSTR||')'; 01973000 CALLINC; 01974000 RETURN(CONDSTR); 01975000 END; 01976000 END; 01977000 ELSE 01978000 IF CHAR = '_' | CHAR = '%' THEN 01979000 DO; 01980000 IF CHAR = '_' THEN 01981000 CALLINC; 01982000 CALL SKIP; 01983000 GO TO NXT2; 01984000 END; 01985000 ELSE 01986000 IF CHAR = '&' THEN 01987000 DO; 01988000 IF SUBSTR(CONDSTR,LENGTH(CONDSTR),1) = '&' THEN 01989000 GO TO NXT1; 01990000 END; 01991000 ELSE 01992000 IF CHAR = '''' THEN 01993000 IF VERIFY(SUBSTR(CONDSTR,LENGTH(CONDSTR),1), /*RAF-14*/ 01994000 'LKNTSI')^=0 THEN /*RAF-14*/ 01994500 DO; 01995000 CONDSTR = CONDSTR||CHAR; 01996000 CSTATE = 1; 01997000 NC: CALLINC; 01998000 NC2: IF COL = 73 THEN 01999000 INDX = 1; 02000000 ELSE 02001000 IF CHAR = '''' THEN 02002000 INDX = 2; 02003000 ELSE 02004000 IF CHAR = '_' THEN 02005000 INDX = 3; 02006000 ELSE 02007000 INDX = 4; 02008000 GO TO STATE(CSTATE,INDX); 02009000 S11: /* IN STRING == EOL */ 02010000 CALL ERROR('COND: MISSING TERMINATING QUOTE.'); 02011000 CONDSTR = CONDSTR||''''; 02012000 GO TO CONDX; 02013000 S12: /* IN STRING == QUOTE */ 02014000 CSTATE = 2; 02015000 S13: /* IN STRING == UNDERSCORE */ 02016000 S14: /* IN STRING == OTHER */ 02017000 ADC: CONDSTR = CONDSTR||CHAR; 02018000 GO TO NC; 02019000 S21: /* TERMINATE TEST == EOL */ 02020000 GO TO NXT1; 02021000 S22: /* TERMINATE TEST == QUOTE */ 02022000 CSTATE = 1; 02023000 GO TO ADC; 02024000 S23: /* TERMINATE TEST == UNDERSCORE */ 02025000 CSTATE = 3; 02026000 CALLINC; 02027000 CALL SKIP; 02028000 GO TO NC2; /*RAF-21*/ 02028500 S24: /* TERMINATE TEST == OTHER */ 02029000 GO TO CONDX; 02030000 S31: /* CONTINUATION TEST == EOL */ 02031000 GO TO CONDX; 02032000 S32: /* CONTINUATION TEST == QUOTE */ 02033000 CONDSTR = SUBSTR(CONDSTR,1,LENGTH(CONDSTR)-1); 02034000 CSTATE = 1; /*RAF-21*/ 02034500 GO TO NC; 02035000 S33: /* CONTINUATION TEST == UNDERSCORE */ 02036000 CALLINC; 02037000 CALL SKIP; 02038000 GO TO NC2; 02039000 S34: /* CONTINUATION TEST == OTHER */ 02040000 CONDX: GO TO NXT2; 02041000 END; 02042000 CONDSTR = CONDSTR||CHAR; 02043000 GO TO NXT1; 02044000 END CONDSCAN; /*RAF-41*/ 02044500 1 02045000 RCHAR: 02046000 PROCEDURE(CH) RETURNS(BIT(1)); /*RAF-41*/ 02047000 DCL 02048000 CH CHAR(1); 02049000 /* TEST INPUT FOR CHARACTER: ADVANCE INDEX IF PRESENT */ 02050000 CALL SKIP ; 02051000 IF CH = CHAR THEN 02052000 DO; 02053000 CALLINC; 02054000 RETURN(#TRUE); 02055000 END ; 02056000 ELSE 02057000 RETURN (#FALSE) ; 02058000 END RCHAR; /*RAF-41*/ 02058500 - 02059000 /* VALUE TRUE AND SKIP WORD IFF NEXT WORD IS 'CHKWORD' */ 02060000 RCHECK: 02061000 PROCEDURE(CHKWORD) RETURNS(BIT(1)); /*RAF-41*/ 02062000 DCL 02063000 CHKWORD CHAR(*) VARYING; 02064000 DCL 02065000 LEN FIXED BIN STATIC; 02066000 LEN=LENGTH(CHKWORD); 02067000 CALL SKIP ; 02068000 IF COL+LEN<=73 THEN /*RAF-41*/ 02068500 IF SUBSTR(CARDIN,COL,LEN) = CHKWORD & (COL+LEN=73 | /*RAF-41*/ 02069000 ^ALPHANUM(SUBSTR(CARDIN,COL+LEN,1))) THEN /*RAF-41*/ 02070000 DO; 02071000 /* DO I = 1 TO LEN ; */ /*RAF-41*/ 02072000 COL = COL+LEN-1; /*RAF-41*/ 02072500 CALLINC; 02073000 /* END; */ /*RAF-41*/ 02074000 RETURN(#TRUE) ; 02075000 END; 02076000 /* ELSE */ /*RAF-47*/ 02077000 RETURN (#FALSE) ; 02078000 END RCHECK; /*RAF-41*/ 02078500 - 02079000 /*ALPHATST: */ /*RAF-41*/ 02080000 /*ENTRY(CHR) RETURNS(BIT(1)); */ /*RAF-41*/ 02081000 /*DCL */ /*RAF-41*/ 02082000 /* CHR CHAR(1); */ /*RAF-41*/ 02083000 /* RETURN(ALPHANUM(CHR)); */ /*RAF-41*/ 02084000 1 02085000 INC: PROCEDURE; 02086000 DCL ( (NSP,NTB) FIXED BIN, /*RAF-17*/ 02087000 FORMCON BIT(1), 02088000 SPLINE CHAR(80) INIT(' SPACE') ) STATIC, 02089000 1 MSPLINE STATIC, 02090000 2 PERSTAR CHAR(2) INIT('.*'), 02091000 2 MSP CHAR(70) INIT(' '), 02092000 2 MSPID CHAR(8), 02093000 1 BALCOM STATIC, 02094000 2 ASTR CHAR(3) INIT('* '), 02095000 2 COMFLD CHAR(68), 02096000 2 COMBLK CHAR(1) INIT(' '), 02097000 2 COMID CHAR(8); 02098000 DECLARE DOTSLSW BIT(1) STATIC; /*RAF-41*/ /*RAF-20*/ 02098500 02099000 COL = 0; 02100000 DOTSLSW = #FALSE; /*RAF-20*/ 02100500 READ FILE(SYSIN) INTO(CARDIN) ; 02101000 DO WHILE(CIN_2COLS='./'); /*RAF-9*/ 02101100 IF NESTLEV^=0 THEN /*RAF-9*/ 02101110 CALL ERROR('INC: ./ CONTROL CARD NOT AT LEVEL 0'); /*RAF-9*/ 02101120 CALL LABPUSH; CALL LABFLUSH; /*RAF-9*/ 02101200 CALL EQVFLUSH(#TRUE,1); /*RAF-9*/ 02101300 SPLINE = '*'; /*RAF-9*/ 02101350 IF ^DOTSLSW THEN SIGNAL ENDPAGE(SYSPRINT);/*RAF-20*//*RAF-9*/ 02101400 PUT FILE(SYSPRINT) EDIT (NESTLEV,CIN_ID,CIN_DATA) /*RAF-9*/ 02101500 (COL(1),X(2),P'Z9',X(2),A,X(1),A); /*RAF-9*/ 02101600 WRITE FILE(SYSOUT) FROM(CARDIN); /*RAF-9*/ 02101700 READ FILE(SYSIN) INTO(CARDIN); /*RAF-9*/ 02101800 DOTSLSW = #TRUE; /*RAF-20*/ 02101850 END; /*RAF-9*/ 02101900 IF CIN_DATA=' ' THEN DO; /*RAF-17*/ 02102000 FORMCON = #FALSE; 02103000 NSP = 1; /*RAF-17*/ 02103100 END; /*RAF-17*/ 02103200 ELSE 02104000 DO; 02105000 NSP = VERIFY(CIN_DATA,' '); 02106000 FORMCON = SUBSTR(CIN_DATA,NSP,5)='SPACE' | 02107000 SUBSTR(CIN_DATA,NSP,5)='EJECT' | 02108000 SUBSTR(CIN_DATA,NSP,5)='TITLE' | 02109000 SUBSTR(CIN_DATA,NSP,8)='SUBTITLE' ; 02110000 END; 02111000 IF SUBTITL THEN SIGNAL ENDPAGE(SYSPRINT); 02112000 IF ^FORMCON | INAL=0 THEN 02113000 DO; 02114000 IF INAL=0 THEN NSP = 1; /*RAF-17*/ 02114100 NTB = 0; /*RAF-17*/ 02114200 IF NESTLEV*3<117-(72-NSP) /*RAF-17*/ 02114300 THEN DO WHILE(SUBSTR(CIN_DATA,72-NTB,1)=' ' /*RAF-17*/ 02114400 & NTB<72); NTB = NTB+1; END; /*RAF-17*/ 02114500 PUT FILE(SYSPRINT) EDIT (NESTLEV,CIN_ID, /*RAF-17*/ 02115000 SUBSTR(CIN_DATA,NSP,73-NSP-NTB)) /*RAF-17*/ 02115100 (COL(1),X(2),P'Z9',X(2),A,X(1), /*RAF-17*/ 02116000 X(MIN(NESTLEV*3,117-(72-NSP-NTB))),A); /*RAF-17*/ 02116100 IF INAL > 0 THEN 02117000 DO; 02118000 COMFLD = SUBSTR(CARDIN,1,68); 02119000 COMID = CIN_ID; 02120000 IF INAL = 1 THEN 02121000 DO; 02122000 INAL = 2; 02123000 IF ^IN_MACRO THEN 02124000 DO; 02125000 WRITE FILE(SYSOUT) FROM(SPLINE); 02126000 ASTR = '* '; 02127000 END; 02128000 ELSE 02129000 DO; 02130000 MSPID = CIN_ID; 02131000 WRITE FILE(SYSOUT) FROM(MSPLINE); 02132000 ASTR = '.* '; 02133000 END; 02134000 END; 02135000 WRITE FILE(SYSOUT) FROM(BALCOM); 02136000 END; 02137000 END; 02138000 COUT_ID = CIN_ID; /* COPY SEQUENCE FIELD */ 02139000 RETURN; 02140000 END INC ; 02141000 1 02142000 /*ALPHANUM: */ /*RAF-41*/ 02143000 /*PROCEDURE(A) RETURNS(BIT(1)); */ /*RAF-41*/ 02144000 /*DCL */ /*RAF-41*/ 02145000 /* A CHAR(1); */ /*RAF-41*/ 02146000 /* VALUE IS TRUE IFF ARGUMENT CHARACTER IS "ALPHANUMERIC" */ 02147000 /* NOTE THAT $,# AND @ ARE ALPHABETIC IN BAL AND THEREFORE IN AL. */ 02148000 /* IF A >= 'A' | A = '$' | A = '@' | A = '#' THEN */ /*RAF-41*/ 02149000 /* RETURN(#TRUE); */ /*RAF-41*/ 02150000 /* ELSE */ /*RAF-41*/ 02151000 /* RETURN(#FALSE); */ /*RAF-41*/ 02152000 /*END ALPHANUM ; */ /*RAF-41*/ 02153000 - 02154000 SKIP: 02155000 PROCEDURE; /* SKIP TO NEXT DATUM (PAST BLANKS AND COMMENTS */ 02156000 /* DO WHILE(CHAR = ' ' | CHAR = '%'); */ /*RAF-41*/ 02157000 /* IF CHAR = ' ' THEN */ /*RAF-41*/ 02158000 /* CALLINC; */ /*RAF-41*/ 02159000 /* ELSE */ /*RAF-41*/ 02160000 /* DO; */ /* SKIP TO "EOL" */ /*RAF-41*/ 02161000 /* COL = 73; */ /*RAF-41*/ 02162000 /* CALLINC; */ /*RAF-41*/ 02163000 /* END; */ /*RAF-41*/ 02164000 /* END; */ /*RAF-41*/ 02165000 /* RETURN; */ /*RAF-41*/ 02166000 /*RAF-41*/ 02166010 DCL NBLANKS FIXED BIN(31) STATIC; /*RAF-41*/ 02166020 /*RAF-41*/ 02166030 DO WHILE('1'B); /*RAF-41*/ 02166040 DO WHILE(CHAR=' '); /*RAF-41*/ 02166050 IF COL>=72 THEN DO; /*RAF-41*/ 02166060 CALL INC; /*RAF-41*/ 02166070 COL = 1; /*RAF-41*/ 02166080 CHAR = SUBSTR(CARDIN,1,1); /*RAF-41*/ 02166090 END; /*RAF-41*/ 02166100 ELSE DO; /*RAF-41*/ 02166110 NBLANKS = VERIFY(SUBSTR(CIN_DATA,COL),' ')-1; /*RAF-41*/ 02166120 IF NBLANKS>0 THEN DO; /*RAF-41*/ 02166130 COL = COL+NBLANKS; /*RAF-41*/ 02166140 CHAR = SUBSTR(CARDIN,COL,1); /*RAF-41*/ 02166150 END; /*RAF-41*/ 02166160 ELSE DO; /*RAF-41*/ 02166170 CALL INC; /*RAF-41*/ 02166180 COL = 1; /*RAF-41*/ 02166190 CHAR = SUBSTR(CARDIN,1,1); /*RAF-41*/ 02166200 END; /*RAF-41*/ 02166210 END; /*RAF-41*/ 02166220 END; /*RAF-41*/ 02166230 IF CHAR='%' THEN DO; /*RAF-41*/ 02166240 CALL INC; /*RAF-41*/ 02166250 COL = 1; /*RAF-41*/ 02166260 CHAR = SUBSTR(CARDIN,1,1); /*RAF-41*/ 02166270 END; /*RAF-41*/ 02166280 ELSE RETURN; /*RAF-41*/ 02166290 END; /*RAF-41*/ 02166300 END SKIP; 02167000 - 02168000 /* END INPUT; */ /*RAF-41*/ 02169000 1 02170000 ERROR: /* ALP ERROR MESSAGE OUTPUT ROUTINES */ 02171000 PROCEDURE(MSG) ; 02172000 DCL 02173000 MSG CHAR(*) VAR ; 02174000 PUT SKIP(2) FILE(SYSTERM) EDIT(CIN_ID,CIN_DATA,MSG) (A,X(1),A,SKIP,A);02175000 PUT SKIP FILE(SYSTERM) EDIT('INPUT AT CHARACTER ''',CHAR,'''', 02176000 ', COLUMN ',COL,' LINE ',CIN_ID, 02177000 ', LAST WORD WAS ''',WORD,'''') (A,A,A,A,F(3),A,A,A,A,A); 02178000 PUT SKIP(2) FILE(SYSPRINT) EDIT('ERROR: ',MSG) (A,A); 02179000 PUT SKIP FILE(SYSPRINT) EDIT('INPUT AT CHARACTER ''',CHAR,'''', 02180000 ', COLUMN ',COL,' LINE ',CIN_ID, 02181000 ', LAST WORD WAS ''',WORD,'''') (A,A,A,A,F(3),A,A,A,A,A); 02182000 PUT SKIP(2) FILE(SYSPRINT) ; 02183000 ERRCNT=ERRCNT+1; 02184000 RETCODE=8; 02185000 RETURN ; 02186000 0OUTPUT: 02187000 ENTRY (MSG) ; 02188000 PUT SKIP FILE(SYSPRINT) EDIT(MSG) (A); 02189000 PUT SKIP FILE(SYSTERM) EDIT(MSG) (A); 02190000 RETURN; 02191000 END ERROR ; 02192000 - 02193000 END ALP; 02194000